{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Duet syntax tokenizer.

module JL.Tokenizer where

import           Control.Monad
import           Data.Char
import           Data.List
import           Data.Text (Text)
import qualified Data.Text as T
import           JL.Types
import           Text.Parsec hiding (anyToken)
import           Text.Parsec.Text
import           Text.Printf

tokenize :: FilePath -> Text -> Either ParseError [(Token, Location)]
tokenize :: [Char] -> Text -> Either ParseError [(Token, Location)]
tokenize [Char]
fp Text
t = Parsec Text () [(Token, Location)]
-> [Char] -> Text -> Either ParseError [(Token, Location)]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec Text () [(Token, Location)]
tokensTokenizer [Char]
fp Text
t

tokensTokenizer :: Parser [(Token, Location)]
tokensTokenizer :: Parsec Text () [(Token, Location)]
tokensTokenizer =
  ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity ()
-> Parsec Text () [(Token, Location)]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill (ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT Text () Identity [Char]
-> ([Char] -> ParsecT Text () Identity (Token, Location))
-> ParsecT Text () Identity (Token, Location)
forall a b.
ParsecT Text () Identity a
-> (a -> ParsecT Text () Identity b) -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> ParsecT Text () Identity (Token, Location)
tokenTokenizer) (ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT Text () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT Text () Identity ()
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof))

tokenTokenizer :: [Char] -> Parser (Token, Location)
tokenTokenizer :: [Char] -> ParsecT Text () Identity (Token, Location)
tokenTokenizer [Char]
prespaces =
  [ParsecT Text () Identity (Token, Location)]
-> ParsecT Text () Identity (Token, Location)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
    [ if [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
"\n" [Char]
prespaces
        then do
          SourcePos
pos <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
          (Token, Location) -> ParsecT Text () Identity (Token, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Token
NonIndentedNewline
            , Int -> Int -> Int -> Int -> Location
Location
                (SourcePos -> Int
sourceLine SourcePos
pos)
                (SourcePos -> Int
sourceColumn SourcePos
pos)
                (SourcePos -> Int
sourceLine SourcePos
pos)
                (SourcePos -> Int
sourceColumn SourcePos
pos))
        else [Char] -> ParsecT Text () Identity (Token, Location)
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected [Char]
"indented newline"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace Token
If [Char]
"if"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace Token
Then [Char]
"then"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace Token
Else [Char]
"else"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace Token
Case [Char]
"case"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace Token
Of [Char]
"of"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
RightArrow [Char]
"->"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Period [Char]
"."
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Colon [Char]
":"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Backslash [Char]
"\\"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
OpenParen [Char]
"("
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
CloseParen [Char]
")"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
OpenBrace [Char]
"{"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
CloseBrace [Char]
"}"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
OpenBracket [Char]
"["
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
CloseBracket [Char]
"]"

    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Dollar [Char]
"$"
    , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Comma [Char]
","

    , do (Token, Location)
tok <-
           (Text -> Token)
-> Parser Text
-> [Char]
-> ParsecT Text () Identity (Token, Location)
forall t.
(Text -> t) -> Parser Text -> [Char] -> Parser (t, Location)
parsing
             Text -> Token
Operator
             (([Char] -> Text) -> ParsecT Text () Identity [Char] -> Parser Text
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                [Char] -> Text
T.pack
                ([ParsecT Text () Identity [Char]]
-> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
                   [ [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"*"
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"+"
                   , ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
">=")
                   , ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"<=")
                   , ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"/=")
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
">"
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"<"
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"/"
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"="
                   , [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"&&"
                   , ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"||")
                   ]))
             [Char]
"operator (e.g. *, <, +, =, etc.)"
         Bool -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
           ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
prespaces)
           ([Char] -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected
              ((Token, Location) -> [Char]
tokenString (Token, Location)
tok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
               [Char]
", there should be spaces before and after operators."))
         ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT Text () Identity ()
spaces1 ParsecT Text () Identity ()
-> [Char] -> ParsecT Text () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> ([Char]
"space after " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Token, Location) -> [Char]
tokenString (Token, Location)
tok)
         (Token, Location) -> ParsecT Text () Identity (Token, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token, Location)
tok
         , Token -> [Char] -> ParsecT Text () Identity (Token, Location)
forall t. t -> [Char] -> Parser (t, Location)
atom Token
Bar [Char]
"|"
    , (Text -> Token)
-> Parser Text
-> [Char]
-> ParsecT Text () Identity (Token, Location)
forall t.
(Text -> t) -> Parser Text -> [Char] -> Parser (t, Location)
parsing
        Text -> Token
StringToken
        (do [Char]
_ <- [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\""
            [Char]
chars <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'))
            Bool -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') [Char]
chars)
              ([Char] -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected [Char]
"\\ character, not allowed inside a string.")
            Bool -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') [Char]
chars)
              ([Char] -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected [Char]
"newline character, not allowed inside a string.")
            [Char]
_ <- [Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\"" ParsecT Text () Identity [Char]
-> [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"double quotes (\") to close the string"
            Text -> Parser Text
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Text
T.pack [Char]
chars))
        [Char]
"string (e.g. \"hello\", \"123\", etc.)"
    , do (Token
var, Location
loc) <-
           (Text -> Token)
-> Parser Text
-> [Char]
-> ParsecT Text () Identity (Token, Location)
forall t.
(Text -> t) -> Parser Text -> [Char] -> Parser (t, Location)
parsing
             Text -> Token
VariableToken
             (do [Char]
variable <-
                   do [Char]
start <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isLetter Char
c))
                      [Char]
end <-
                        ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many
                          ((Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy
                             (\Char
c -> Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c))
                      [Char] -> ParsecT Text () Identity [Char]
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
start [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
end)
                 Text -> Parser Text
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Text
T.pack [Char]
variable))
             [Char]
"variable (e.g. “elephant”, “age”, “t2”, etc.)"
         (Token, Location) -> ParsecT Text () Identity (Token, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
           ( case Token
var of
               VariableToken Text
"null" -> Token
NullToken
               VariableToken Text
"true" -> Token
TrueToken
               VariableToken Text
"false" -> Token
FalseToken
               Token
_ -> Token
var
           , Location
loc)
    , [Char] -> ParsecT Text () Identity (Token, Location)
forall a. [a] -> ParsecT Text () Identity (Token, Location)
parseNumbers [Char]
prespaces
    ]
  where

spaces1 :: Parser ()
spaces1 :: ParsecT Text () Identity ()
spaces1 = ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

ellipsis :: Int -> [Char] -> [Char]
ellipsis :: Int -> [Char] -> [Char]
ellipsis Int
n [Char]
text =
  if [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2
    then Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
n [Char]
text [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"…"
    else [Char]
text

specialParsing ::  (t1 -> t) -> Parser  t1 -> String -> Parser  (t, Location)
specialParsing :: forall t1 t.
(t1 -> t) -> Parser t1 -> [Char] -> Parser (t, Location)
specialParsing t1 -> t
constructor Parser t1
parser [Char]
description = do
  SourcePos
start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  t1
thing <- Parser t1
parser Parser t1 -> [Char] -> Parser t1
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
description
  SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  (t, Location) -> Parser (t, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( t1 -> t
constructor t1
thing
    , Int -> Int -> Int -> Int -> Location
Location
        (SourcePos -> Int
sourceLine SourcePos
start)
        (SourcePos -> Int
sourceColumn SourcePos
start)
        (SourcePos -> Int
sourceLine SourcePos
end)
        (SourcePos -> Int
sourceColumn SourcePos
end))

atom ::  t -> String -> Parser  (t, Location)
atom :: forall t. t -> [Char] -> Parser (t, Location)
atom t
constructor [Char]
text = do
  SourcePos
start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  [Char]
_ <- ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
text) ParsecT Text () Identity [Char]
-> [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char] -> [Char]
smartQuotes [Char]
text
  SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  (t, Location) -> Parser (t, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( t
constructor
    , Int -> Int -> Int -> Int -> Location
Location
        (SourcePos -> Int
sourceLine SourcePos
start)
        (SourcePos -> Int
sourceColumn SourcePos
start)
        (SourcePos -> Int
sourceLine SourcePos
end)
        (SourcePos -> Int
sourceColumn SourcePos
end))

atomThenSpace :: t -> String -> Parser (t, Location)
atomThenSpace :: forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace t
constructor [Char]
text = do
  SourcePos
start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  [Char]
_ <-
    ParsecT Text () Identity [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (([Char] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
text ParsecT Text () Identity [Char]
-> [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char] -> [Char]
smartQuotes [Char]
text) ParsecT Text () Identity [Char]
-> ParsecT Text () Identity () -> ParsecT Text () Identity [Char]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
         (ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT Text () Identity ()
spaces1 ParsecT Text () Identity ()
-> [Char] -> ParsecT Text () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> ([Char]
"space or newline after " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
smartQuotes [Char]
text)))
  SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  (t, Location) -> Parser (t, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( t
constructor
    , Int -> Int -> Int -> Int -> Location
Location
        (SourcePos -> Int
sourceLine SourcePos
start)
        (SourcePos -> Int
sourceColumn SourcePos
start)
        (SourcePos -> Int
sourceLine SourcePos
end)
        (SourcePos -> Int
sourceColumn SourcePos
end))

parsing ::  (Text -> t) -> Parser  Text -> String -> Parser  (t, Location)
parsing :: forall t.
(Text -> t) -> Parser Text -> [Char] -> Parser (t, Location)
parsing Text -> t
constructor Parser Text
parser [Char]
description = do
  SourcePos
start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  Text
text <- Parser Text
parser Parser Text -> [Char] -> Parser Text
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
description
  SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  (t, Location) -> Parser (t, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Text -> t
constructor Text
text
    , Int -> Int -> Int -> Int -> Location
Location
        (SourcePos -> Int
sourceLine SourcePos
start)
        (SourcePos -> Int
sourceColumn SourcePos
start)
        (SourcePos -> Int
sourceLine SourcePos
end)
        (SourcePos -> Int
sourceColumn SourcePos
end))

parseNumbers :: [a] -> Parser (Token, Location)
parseNumbers :: forall a. [a] -> ParsecT Text () Identity (Token, Location)
parseNumbers [a]
prespaces = ParsecT Text () Identity (Token, Location)
parser ParsecT Text () Identity (Token, Location)
-> [Char] -> ParsecT Text () Identity (Token, Location)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"number (e.g. 42, 3.141, etc.)"
  where
    parser :: ParsecT Text () Identity (Token, Location)
parser = do
      SourcePos
start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
      Maybe Char
neg <- (Char -> Maybe Char)
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity (Maybe Char)
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-') ParsecT Text () Identity (Maybe Char)
-> ParsecT Text () Identity (Maybe Char)
-> ParsecT Text () Identity (Maybe Char)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Maybe Char -> ParsecT Text () Identity (Maybe Char)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Char
forall a. Maybe a
Nothing
      let operator :: ParsecT s u Identity (Token, Location)
operator = do
            SourcePos
end <- ParsecT s u Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
            (Token, Location) -> ParsecT s u Identity (Token, Location)
forall a. a -> ParsecT s u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( Text -> Token
Operator Text
"-"
              , Int -> Int -> Int -> Int -> Location
Location
                  (SourcePos -> Int
sourceLine SourcePos
start)
                  (SourcePos -> Int
sourceColumn SourcePos
start)
                  (SourcePos -> Int
sourceLine SourcePos
end)
                  (SourcePos -> Int
sourceColumn SourcePos
end))
          number
            :: (forall a. (Num a) =>
                            a -> a)
            -> Parser (Token, Location)
          number :: (forall a. Num a => a -> a)
-> ParsecT Text () Identity (Token, Location)
number forall a. Num a => a -> a
f = do
            [Char]
x <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
            (do Char
_ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
                [Char]
y <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT Text () Identity [Char]
-> [Char] -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> ([Char]
"decimal component, e.g. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".0")
                SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                (Token, Location) -> ParsecT Text () Identity (Token, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  ( Double -> Token
Decimal (Double -> Double
forall a. Num a => a -> a
f ([Char] -> Double
forall a. Read a => [Char] -> a
read ([Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y)))
                  , Int -> Int -> Int -> Int -> Location
Location
                      (SourcePos -> Int
sourceLine SourcePos
start)
                      (SourcePos -> Int
sourceColumn SourcePos
start)
                      (SourcePos -> Int
sourceLine SourcePos
end)
                      (SourcePos -> Int
sourceColumn SourcePos
end))) ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity (Token, Location)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              (do SourcePos
end <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                  (Token, Location) -> ParsecT Text () Identity (Token, Location)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    ( Integer -> Token
Integer (Integer -> Integer
forall a. Num a => a -> a
f ([Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
x))
                    , Int -> Int -> Int -> Int -> Location
Location
                        (SourcePos -> Int
sourceLine SourcePos
start)
                        (SourcePos -> Int
sourceColumn SourcePos
start)
                        (SourcePos -> Int
sourceLine SourcePos
end)
                        (SourcePos -> Int
sourceColumn SourcePos
end)))
      case Maybe Char
neg of
        Maybe Char
Nothing -> (forall a. Num a => a -> a)
-> ParsecT Text () Identity (Token, Location)
number a -> a
forall a. a -> a
forall a. Num a => a -> a
id
        Just {} -> do
          Bool -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
prespaces)
            ([Char] -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected
               ([Char] -> [Char]
curlyQuotes [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", there should be a space before it."))
          ((forall a. Num a => a -> a)
-> ParsecT Text () Identity (Token, Location)
number (a -> a -> a
forall a. Num a => a -> a -> a
* (-a
1)) ParsecT Text () Identity (Token, Location)
-> [Char] -> ParsecT Text () Identity (Token, Location)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"number (e.g. 123)") ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity (Token, Location)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ParsecT Text () Identity (Token, Location)
forall {s} {u}. ParsecT s u Identity (Token, Location)
operator ParsecT Text () Identity (Token, Location)
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity (Token, Location)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT Text () Identity Char
-> [Char] -> ParsecT Text () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> ([Char]
"space after operator " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes [Char]
"-"))

smartQuotes :: [Char] -> [Char]
smartQuotes :: [Char] -> [Char]
smartQuotes [Char]
t = [Char]
"“" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
t [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"”"

equalToken :: Token -> TokenParser Location
equalToken :: Token -> TokenParser Location
equalToken Token
p = ((Token, Location) -> Location)
-> ParsecT s Int m (Token, Location) -> ParsecT s Int m Location
forall a b. (a -> b) -> ParsecT s Int m a -> ParsecT s Int m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token, Location) -> Location
forall a b. (a, b) -> b
snd ((Token -> Bool) -> TokenParser (Token, Location)
satisfyToken (Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
==Token
p) ParsecT s Int m (Token, Location)
-> [Char] -> ParsecT s Int m (Token, Location)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> Token -> [Char]
tokenStr Token
p)

-- | Consume the given predicate from the token stream.
satisfyToken :: (Token -> Bool) -> TokenParser (Token, Location)
satisfyToken :: (Token -> Bool) -> TokenParser (Token, Location)
satisfyToken Token -> Bool
p =
  (Token -> Maybe Token) -> TokenParser (Token, Location)
forall a. (Token -> Maybe a) -> TokenParser (a, Location)
consumeToken (\Token
tok -> if Token -> Bool
p Token
tok
                           then Token -> Maybe Token
forall a. a -> Maybe a
Just Token
tok
                           else Maybe Token
forall a. Maybe a
Nothing)

-- | The parser @anyToken@ accepts any kind of token. It is for example
-- used to implement 'eof'. Returns the accepted token.
anyToken :: TokenParser (Token, Location)
anyToken :: TokenParser (Token, Location)
anyToken = (Token -> Maybe Token) -> TokenParser (Token, Location)
forall a. (Token -> Maybe a) -> TokenParser (a, Location)
consumeToken Token -> Maybe Token
forall a. a -> Maybe a
Just

-- | Consume the given predicate from the token stream.
consumeToken :: (Token -> Maybe a) -> TokenParser (a, Location)
consumeToken :: forall a. (Token -> Maybe a) -> TokenParser (a, Location)
consumeToken Token -> Maybe a
f = do
  Int
u <- ParsecT s Int m Int
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  ((Token, Location) -> [Char])
-> (SourcePos -> (Token, Location) -> s -> SourcePos)
-> ((Token, Location) -> Maybe (a, Location))
-> ParsecT s Int m (a, Location)
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> [Char])
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim
    (Token, Location) -> [Char]
tokenString
    SourcePos -> (Token, Location) -> s -> SourcePos
forall t. SourcePos -> (Token, Location) -> t -> SourcePos
tokenPosition
    (\(Token
tok, Location
loc) ->
       if Location -> Int
locationStartColumn Location
loc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
u
         then (a -> (a, Location)) -> Maybe a -> Maybe (a, Location)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Location
loc) (Token -> Maybe a
f Token
tok)
         else Maybe (a, Location)
forall a. Maybe a
Nothing)

-- | Make a string out of the token, for error message purposes.
tokenString :: (Token, Location) -> [Char]
tokenString :: (Token, Location) -> [Char]
tokenString = Token -> [Char]
tokenStr (Token -> [Char])
-> ((Token, Location) -> Token) -> (Token, Location) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token, Location) -> Token
forall a b. (a, b) -> a
fst

tokenStr :: Token -> [Char]
tokenStr :: Token -> [Char]
tokenStr Token
tok =
  case Token
tok of
    Token
If -> [Char] -> [Char]
curlyQuotes [Char]
"if"
    Token
Then -> [Char] -> [Char]
curlyQuotes [Char]
"then"
    Token
RightArrow -> [Char] -> [Char]
curlyQuotes [Char]
"->"
    Token
Else -> [Char] -> [Char]
curlyQuotes [Char]
"else"
    Token
Case -> [Char] -> [Char]
curlyQuotes [Char]
"case"
    Token
Of -> [Char] -> [Char]
curlyQuotes [Char]
"of"
    Token
NonIndentedNewline -> [Char]
"non-indented newline"
    Token
Backslash -> [Char] -> [Char]
curlyQuotes ([Char]
"backslash " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes [Char]
"\\")
    Token
OpenParen -> [Char]
"opening parenthesis " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes [Char]
"("
    Token
CloseParen -> [Char]
"closing parenthesis " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes [Char]
")"
    VariableToken Text
t -> [Char]
"variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes (Text -> [Char]
T.unpack Text
t)
    StringToken !Text
t -> [Char]
"string " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t
    Operator !Text
t -> [Char]
"operator " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
curlyQuotes (Text -> [Char]
T.unpack Text
t)
    Token
Comma -> [Char] -> [Char]
curlyQuotes [Char]
","
    Integer !Integer
i -> [Char]
"integer " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i
    Decimal !Double
d -> [Char]
"decimal " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%f" Double
d
    Token
Bar -> [Char] -> [Char]
curlyQuotes [Char]
"|"
    Token
Dollar -> [Char] -> [Char]
curlyQuotes [Char]
"$"
    Token
Period -> [Char] -> [Char]
curlyQuotes [Char]
"."
    Token
TrueToken -> [Char] -> [Char]
curlyQuotes [Char]
"true"
    Token
FalseToken -> [Char] -> [Char]
curlyQuotes [Char]
"false"
    Token
NullToken -> [Char] -> [Char]
curlyQuotes [Char]
"null"
    Token
CloseBrace -> [Char] -> [Char]
curlyQuotes [Char]
"}"
    Token
OpenBrace -> [Char] -> [Char]
curlyQuotes [Char]
"{"
    Token
CloseBracket -> [Char] -> [Char]
curlyQuotes [Char]
"]"
    Token
OpenBracket -> [Char] -> [Char]
curlyQuotes [Char]
"["
    Token
Colon -> [Char] -> [Char]
curlyQuotes [Char]
":"

-- | Update the position by the token.
tokenPosition :: SourcePos -> (Token, Location) -> t -> SourcePos
tokenPosition :: forall t. SourcePos -> (Token, Location) -> t -> SourcePos
tokenPosition SourcePos
pos (Token
_, Location
l) t
_ =
  SourcePos -> Int -> SourcePos
setSourceColumn (SourcePos -> Int -> SourcePos
setSourceLine SourcePos
pos Int
line) Int
col
  where (Int
line,Int
col) = (Location -> Int
locationStartLine Location
l, Location -> Int
locationStartColumn Location
l)

type TokenParser e = forall s m. Stream s m (Token, Location) => ParsecT s Int m e

-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser
-- does not consume any input. This parser can be used to implement the
-- \'longest match\' rule. For example, when recognizing keywords (for
-- example @let@), we want to make sure that a keyword is not followed
-- by a legal identifier character, in which case the keyword is
-- actually an identifier (for example @lets@). We can program this
-- behaviour as follows:
--
-- >  keywordLet  = try (do{ string "let"
-- >                       ; notFollowedBy alphaNum
-- >                       })
notFollowedBy' :: TokenParser (Token, Location) -> TokenParser ()
notFollowedBy' :: TokenParser (Token, Location) -> TokenParser ()
notFollowedBy' TokenParser (Token, Location)
p =
  ParsecT s Int m () -> ParsecT s Int m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ((do (Token, Location)
c <- ParsecT s Int m (Token, Location)
-> ParsecT s Int m (Token, Location)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT s Int m (Token, Location)
TokenParser (Token, Location)
p
           [Char] -> ParsecT s Int m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected ((Token, Location) -> [Char]
tokenString (Token, Location)
c)) ParsecT s Int m () -> ParsecT s Int m () -> ParsecT s Int m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       () -> ParsecT s Int m ()
forall a. a -> ParsecT s Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | This parser only succeeds at the end of the input. This is not a
-- primitive parser but it is defined using 'notFollowedBy'.
--
-- >  eof  = notFollowedBy anyToken <?> "end of input"
endOfTokens :: TokenParser ()
endOfTokens :: TokenParser ()
endOfTokens = TokenParser (Token, Location) -> TokenParser ()
notFollowedBy' ParsecT s Int m (Token, Location)
TokenParser (Token, Location)
anyToken ParsecT s Int m () -> [Char] -> ParsecT s Int m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"end of input"

curlyQuotes :: [Char] -> [Char]
curlyQuotes :: [Char] -> [Char]
curlyQuotes [Char]
t = [Char]
"‘" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
t [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"’"