{-# 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
          pos <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
          pure
            ( NonIndentedNewline
            , Location
                (sourceLine pos)
                (sourceColumn pos)
                (sourceLine pos)
                (sourceColumn 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 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.)"
         when
           (null prespaces)
           (unexpected
              (tokenString tok ++
               ", there should be spaces before and after operators."))
         lookAhead spaces1 <?> ("space after " ++ tokenString tok)
         pure 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] -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\""
            chars <- many (satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'))
            when
              (any (== '\\') chars)
              (unexpected "\\ character, not allowed inside a string.")
            when
              (any (== '\n') chars)
              (unexpected "newline character, not allowed inside a string.")
            _ <- string "\"" <?> "double quotes (\") to close the string"
            pure (T.pack chars))
        [Char]
"string (e.g. \"hello\", \"123\", etc.)"
    , do (var, 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 variable <-
                   do start <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. 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))
                      end <-
                        many
                          (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))
                      pure (start ++ end)
                 pure (T.pack variable))
             [Char]
"variable (e.g. “elephant”, “age”, “t2”, etc.)"
         pure
           ( case var of
               VariableToken Text
"null" -> Token
NullToken
               VariableToken Text
"true" -> Token
TrueToken
               VariableToken Text
"false" -> Token
FalseToken
               Token
_ -> Token
var
           , 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
  start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  thing <- parser <?> description
  end <- getPosition
  pure
    ( constructor thing
    , Location
        (sourceLine start)
        (sourceColumn start)
        (sourceLine end)
        (sourceColumn end))

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

atomThenSpace :: t -> String -> Parser (t, Location)
atomThenSpace :: forall t. t -> [Char] -> Parser (t, Location)
atomThenSpace t
constructor [Char]
text = do
  start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  _ <-
    try ((string text <?> smartQuotes text) <*
         (lookAhead spaces1 <?> ("space or newline after " ++ smartQuotes text)))
  end <- getPosition
  pure
    ( constructor
    , Location
        (sourceLine start)
        (sourceColumn start)
        (sourceLine end)
        (sourceColumn 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
  start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  text <- parser <?> description
  end <- getPosition
  pure
    ( constructor text
    , Location
        (sourceLine start)
        (sourceColumn start)
        (sourceLine end)
        (sourceColumn 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
      start <- ParsecT Text () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
      neg <- fmap Just (char '-') <|> pure Nothing
      let operator = do
            end <- ParsecT s u Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
            pure
              ( Operator "-"
              , Location
                  (sourceLine start)
                  (sourceColumn start)
                  (sourceLine end)
                  (sourceColumn end))
          number
            :: (forall a. (Num a) =>
                            a -> a)
            -> Parser (Token, Location)
          number forall a. Num a => a -> a
f = do
            x <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s u (m :: * -> *) a. 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 '.'
                y <- many1 digit <?> ("decimal component, e.g. " ++ x ++ ".0")
                end <- getPosition
                pure
                  ( Decimal (f (read (x ++ "." ++ y)))
                  , Location
                      (sourceLine start)
                      (sourceColumn start)
                      (sourceLine end)
                      (sourceColumn end))) <|>
              (do end <- getPosition
                  pure
                    ( Integer (f (read x))
                    , Location
                        (sourceLine start)
                        (sourceColumn start)
                        (sourceLine end)
                        (sourceColumn end)))
      case 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
  u <- ParsecT s Int m Int
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  tokenPrim
    tokenString
    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 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
           unexpected (tokenString 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]
"’"