module Language.PureScript.CST.Lexer
  ( lenient
  , lexModule
  , lex
  , lexTopLevel
  , lexWithState
  , isUnquotedKey
  ) where

import Prelude hiding (lex, exp, exponent, lines)

import Control.Monad (join)
import qualified Data.Char as Char
import qualified Data.DList as DList
import Data.Foldable (foldl')
import Data.Functor (($>))
import qualified Data.Scientific as Sci
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.PureScript as Text
import Language.PureScript.CST.Errors
import Language.PureScript.CST.Monad hiding (token)
import Language.PureScript.CST.Layout
import Language.PureScript.CST.Positions
import Language.PureScript.CST.Types

-- | Stops at the first lexing error and replaces it with TokEof. Otherwise,
-- the parser will fail when it attempts to draw a lookahead token.
lenient :: [LexResult] -> [LexResult]
lenient :: [LexResult] -> [LexResult]
lenient = forall {b} {a}.
[Either (LexState, b) SourceToken] -> [Either a SourceToken]
go
  where
  go :: [Either (LexState, b) SourceToken] -> [Either a SourceToken]
go [] = []
  go (Right SourceToken
a : [Either (LexState, b) SourceToken]
as) = forall a b. b -> Either a b
Right SourceToken
a forall a. a -> [a] -> [a]
: [Either (LexState, b) SourceToken] -> [Either a SourceToken]
go [Either (LexState, b) SourceToken]
as
  go (Left (LexState
st, b
_) : [Either (LexState, b) SourceToken]
_) = do
    let
      pos :: SourcePos
pos = LexState -> SourcePos
lexPos LexState
st
      ann :: TokenAnn
ann = SourceRange -> [Comment LineFeed] -> [Comment Void] -> TokenAnn
TokenAnn (SourcePos -> SourcePos -> SourceRange
SourceRange SourcePos
pos SourcePos
pos) (LexState -> [Comment LineFeed]
lexLeading LexState
st) []
    [forall a b. b -> Either a b
Right (TokenAnn -> Token -> SourceToken
SourceToken TokenAnn
ann Token
TokEof)]

lexModule :: Text -> [LexResult]
lexModule :: Text -> [LexResult]
lexModule = (Text -> ([Comment LineFeed], Text)) -> Text -> [LexResult]
lex' Text -> ([Comment LineFeed], Text)
shebangThenComments

-- | Lexes according to root layout rules.
lex :: Text -> [LexResult]
lex :: Text -> [LexResult]
lex = (Text -> ([Comment LineFeed], Text)) -> Text -> [LexResult]
lex' Text -> ([Comment LineFeed], Text)
comments

lex' :: (Text -> ([Comment LineFeed], Text)) -> Text -> [LexResult]
lex' :: (Text -> ([Comment LineFeed], Text)) -> Text -> [LexResult]
lex' Text -> ([Comment LineFeed], Text)
lexComments Text
src = do
  let ([Comment LineFeed]
leading, Text
src') = Text -> ([Comment LineFeed], Text)
lexComments Text
src

  LexState -> [LexResult]
lexWithState forall a b. (a -> b) -> a -> b
$ LexState
    { lexPos :: SourcePos
lexPos = SourcePos -> [Comment LineFeed] -> SourcePos
advanceLeading (Int -> Int -> SourcePos
SourcePos Int
1 Int
1) [Comment LineFeed]
leading
    , lexLeading :: [Comment LineFeed]
lexLeading = [Comment LineFeed]
leading
    , lexSource :: Text
lexSource = Text
src'
    , lexStack :: LayoutStack
lexStack = [(Int -> Int -> SourcePos
SourcePos Int
0 Int
0, LayoutDelim
LytRoot)]
    }

-- | Lexes according to top-level declaration context rules.
lexTopLevel :: Text -> [LexResult]
lexTopLevel :: Text -> [LexResult]
lexTopLevel Text
src = do
  let
    ([Comment LineFeed]
leading, Text
src') = Text -> ([Comment LineFeed], Text)
comments Text
src
    lexPos :: SourcePos
lexPos = SourcePos -> [Comment LineFeed] -> SourcePos
advanceLeading (Int -> Int -> SourcePos
SourcePos Int
1 Int
1) [Comment LineFeed]
leading
    hd :: LexResult
hd = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SourcePos -> Token -> SourceToken
lytToken SourcePos
lexPos Token
TokLayoutStart
    tl :: [LexResult]
tl = LexState -> [LexResult]
lexWithState forall a b. (a -> b) -> a -> b
$ LexState
      { lexPos :: SourcePos
lexPos = SourcePos
lexPos
      , lexLeading :: [Comment LineFeed]
lexLeading = [Comment LineFeed]
leading
      , lexSource :: Text
lexSource = Text
src'
      , lexStack :: LayoutStack
lexStack = [(SourcePos
lexPos, LayoutDelim
LytWhere), (Int -> Int -> SourcePos
SourcePos Int
0 Int
0, LayoutDelim
LytRoot)]
      }
  LexResult
hd forall a. a -> [a] -> [a]
: [LexResult]
tl

-- | Lexes according to some LexState.
lexWithState :: LexState -> [LexResult]
lexWithState :: LexState -> [LexResult]
lexWithState = LexState -> [LexResult]
go
  where
  Parser forall r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> (Token, ([Comment void], [Comment LineFeed])) -> r)
-> r
lexK =
    forall void. Lexer (Token, ([Comment void], [Comment LineFeed]))
tokenAndComments

  go :: LexState -> [LexResult]
go state :: LexState
state@LexState {LayoutStack
[Comment LineFeed]
Text
SourcePos
lexStack :: LayoutStack
lexSource :: Text
lexLeading :: [Comment LineFeed]
lexPos :: SourcePos
lexStack :: LexState -> LayoutStack
lexSource :: LexState -> Text
lexLeading :: LexState -> [Comment LineFeed]
lexPos :: LexState -> SourcePos
..} =
    forall {void} r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> (Token, ([Comment void], [Comment LineFeed])) -> r)
-> r
lexK Text
lexSource Text -> ParserErrorType -> [LexResult]
onError Text
-> (Token, ([Comment Void], [Comment LineFeed])) -> [LexResult]
onSuccess
    where
    onError :: Text -> ParserErrorType -> [LexResult]
onError Text
lexSource' ParserErrorType
err = do
      let
        len1 :: Int
len1 = Text -> Int
Text.length Text
lexSource
        len2 :: Int
len2 = Text -> Int
Text.length Text
lexSource'
        chunk :: Text
chunk = Int -> Text -> Text
Text.take (forall a. Ord a => a -> a -> a
max Int
0 (Int
len1 forall a. Num a => a -> a -> a
- Int
len2)) Text
lexSource
        chunkDelta :: (Int, Int)
chunkDelta = Text -> (Int, Int)
textDelta Text
chunk
        pos :: SourcePos
pos = SourcePos -> (Int, Int) -> SourcePos
applyDelta SourcePos
lexPos (Int, Int)
chunkDelta
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
        ( LexState
state { lexSource :: Text
lexSource = Text
lexSource' }
        , forall a.
SourceRange
-> [SourceToken] -> LayoutStack -> a -> ParserErrorInfo a
ParserErrorInfo (SourcePos -> SourcePos -> SourceRange
SourceRange SourcePos
pos forall a b. (a -> b) -> a -> b
$ SourcePos -> (Int, Int) -> SourcePos
applyDelta SourcePos
pos (Int
0, Int
1)) [] LayoutStack
lexStack ParserErrorType
err
        )

    onSuccess :: Text
-> (Token, ([Comment Void], [Comment LineFeed])) -> [LexResult]
onSuccess Text
_ (Token
TokEof, ([Comment Void], [Comment LineFeed])
_) =
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourcePos -> [Comment LineFeed] -> LayoutStack -> [SourceToken]
unwindLayout SourcePos
lexPos [Comment LineFeed]
lexLeading LayoutStack
lexStack
    onSuccess Text
lexSource' (Token
tok, ([Comment Void]
trailing, [Comment LineFeed]
lexLeading')) = do
      let
        endPos :: SourcePos
endPos = SourcePos -> Token -> SourcePos
advanceToken SourcePos
lexPos Token
tok
        lexPos' :: SourcePos
lexPos' = SourcePos -> [Comment LineFeed] -> SourcePos
advanceLeading (SourcePos -> [Comment Void] -> SourcePos
advanceTrailing SourcePos
endPos [Comment Void]
trailing) [Comment LineFeed]
lexLeading'
        tokenAnn :: TokenAnn
tokenAnn = TokenAnn
          { tokRange :: SourceRange
tokRange = SourcePos -> SourcePos -> SourceRange
SourceRange SourcePos
lexPos SourcePos
endPos
          , tokLeadingComments :: [Comment LineFeed]
tokLeadingComments = [Comment LineFeed]
lexLeading
          , tokTrailingComments :: [Comment Void]
tokTrailingComments = [Comment Void]
trailing
          }
        (LayoutStack
lexStack', [SourceToken]
toks) =
          SourceToken
-> SourcePos -> LayoutStack -> (LayoutStack, [SourceToken])
insertLayout (TokenAnn -> Token -> SourceToken
SourceToken TokenAnn
tokenAnn Token
tok) SourcePos
lexPos' LayoutStack
lexStack
        state' :: LexState
state' = LexState
          { lexPos :: SourcePos
lexPos = SourcePos
lexPos'
          , lexLeading :: [Comment LineFeed]
lexLeading = [Comment LineFeed]
lexLeading'
          , lexSource :: Text
lexSource = Text
lexSource'
          , lexStack :: LayoutStack
lexStack = LayoutStack
lexStack'
          }
      LexState -> [SourceToken] -> [LexResult]
go2 LexState
state' [SourceToken]
toks

  go2 :: LexState -> [SourceToken] -> [LexResult]
go2 LexState
state [] = LexState -> [LexResult]
go LexState
state
  go2 LexState
state (SourceToken
t : [SourceToken]
ts) = forall a b. b -> Either a b
Right SourceToken
t forall a. a -> [a] -> [a]
: LexState -> [SourceToken] -> [LexResult]
go2 LexState
state [SourceToken]
ts

type Lexer = ParserM ParserErrorType Text

{-# INLINE next #-}
next :: Lexer ()
next :: Lexer ()
next = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> () -> r
ksucc ->
  Text -> () -> r
ksucc (Int -> Text -> Text
Text.drop Int
1 Text
inp) ()

{-# INLINE nextWhile #-}
nextWhile :: (Char -> Bool) -> Lexer Text
nextWhile :: (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
p = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Text -> r
ksucc -> do
  let (Text
chs, Text
inp') = (Char -> Bool) -> Text -> (Text, Text)
Text.span Char -> Bool
p Text
inp
  Text -> Text -> r
ksucc Text
inp' Text
chs

{-# INLINE nextWhile' #-}
nextWhile' :: Int -> (Char -> Bool) -> Lexer Text
nextWhile' :: Int -> (Char -> Bool) -> Lexer Text
nextWhile' Int
n Char -> Bool
p = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Text -> r
ksucc -> do
  let (Text
chs, Text
inp') = Int -> (Char -> Bool) -> Text -> (Text, Text)
Text.spanUpTo Int
n Char -> Bool
p Text
inp
  Text -> Text -> r
ksucc Text
inp' Text
chs

{-# INLINE peek #-}
peek :: Lexer (Maybe Char)
peek :: Lexer (Maybe Char)
peek = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Maybe Char -> r
ksucc ->
  if Text -> Bool
Text.null Text
inp
    then Text -> Maybe Char -> r
ksucc Text
inp forall a. Maybe a
Nothing
    else Text -> Maybe Char -> r
ksucc Text
inp forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Char
Text.head Text
inp

{-# INLINE restore #-}
restore :: (ParserErrorType -> Bool) -> Lexer a -> Lexer a
restore :: forall a. (ParserErrorType -> Bool) -> Lexer a -> Lexer a
restore ParserErrorType -> Bool
p (Parser forall r.
Text -> (Text -> ParserErrorType -> r) -> (Text -> a -> r) -> r
k) = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
kerr Text -> a -> r
ksucc ->
  forall r.
Text -> (Text -> ParserErrorType -> r) -> (Text -> a -> r) -> r
k Text
inp (\Text
inp' ParserErrorType
err -> Text -> ParserErrorType -> r
kerr (if ParserErrorType -> Bool
p ParserErrorType
err then Text
inp else Text
inp') ParserErrorType
err) Text -> a -> r
ksucc

tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed]))
tokenAndComments :: forall void. Lexer (Token, ([Comment void], [Comment LineFeed]))
tokenAndComments = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Token
token forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall void. Lexer ([Comment void], [Comment LineFeed])
breakComments

shebangThenComments :: Text -> ([Comment LineFeed], Text)
shebangThenComments :: Text -> ([Comment LineFeed], Text)
shebangThenComments Text
src = do
  let
    ([Comment LineFeed]
sb, ([Comment LineFeed]
coms, Text
src')) = Text -> ([Comment LineFeed], Text)
comments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ([Comment LineFeed], Text)
shebang Text
src
  ([Comment LineFeed]
sb forall a. Semigroup a => a -> a -> a
<> [Comment LineFeed]
coms, Text
src')

shebang :: Text -> ([Comment LineFeed], Text)
shebang :: Text -> ([Comment LineFeed], Text)
shebang = \Text
src -> forall r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> [Comment LineFeed] -> r)
-> r
k Text
src (\Text
_ ParserErrorType
_ -> ([], Text
src)) (\Text
inp [Comment LineFeed]
a -> ([Comment LineFeed]
a, Text
inp))
  where
  Parser forall r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> [Comment LineFeed] -> r)
-> r
k = ParserM ParserErrorType Text [Comment LineFeed]
breakShebang

comments :: Text -> ([Comment LineFeed], Text)
comments :: Text -> ([Comment LineFeed], Text)
comments = \Text
src -> forall {void} r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> ([Comment void], [Comment LineFeed]) -> r)
-> r
k Text
src (\Text
_ ParserErrorType
_ -> ([], Text
src)) (\Text
inp ([Comment LineFeed]
a, [Comment LineFeed]
b) -> ([Comment LineFeed]
a forall a. Semigroup a => a -> a -> a
<> [Comment LineFeed]
b, Text
inp))
  where
  Parser forall r.
Text
-> (Text -> ParserErrorType -> r)
-> (Text -> ([Comment void], [Comment LineFeed]) -> r)
-> r
k = forall void. Lexer ([Comment void], [Comment LineFeed])
breakComments

breakComments :: Lexer ([Comment void], [Comment LineFeed])
breakComments :: forall void. Lexer ([Comment void], [Comment LineFeed])
breakComments = forall {l}.
[Comment l]
-> ParserM ParserErrorType Text ([Comment l], [Comment LineFeed])
k0 []
  where
  k0 :: [Comment l]
-> ParserM ParserErrorType Text ([Comment l], [Comment LineFeed])
k0 [Comment l]
acc = do
    Text
spaces <- (Char -> Bool) -> Lexer Text
nextWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
    Text
lines  <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isLineFeed
    let
      acc' :: [Comment l]
acc'
        | Text -> Bool
Text.null Text
spaces = [Comment l]
acc
        | Bool
otherwise = forall l. Int -> Comment l
Space (Text -> Int
Text.length Text
spaces) forall a. a -> [a] -> [a]
: [Comment l]
acc
    if Text -> Bool
Text.null Text
lines
      then do
        Maybe (Comment l)
mbComm <- forall {l}. ParserM ParserErrorType Text (Maybe (Comment l))
comment
        case Maybe (Comment l)
mbComm of
          Just Comment l
comm -> [Comment l]
-> ParserM ParserErrorType Text ([Comment l], [Comment LineFeed])
k0 (Comment l
comm forall a. a -> [a] -> [a]
: [Comment l]
acc')
          Maybe (Comment l)
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse [Comment l]
acc', [])
      else
        forall {a}.
[a]
-> [Comment LineFeed]
-> ParserM ParserErrorType Text ([a], [Comment LineFeed])
k1 [Comment l]
acc' ([Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs [] forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
lines)

  k1 :: [a]
-> [Comment LineFeed]
-> ParserM ParserErrorType Text ([a], [Comment LineFeed])
k1 [a]
trl [Comment LineFeed]
acc = do
    Text
ws <- (Char -> Bool) -> Lexer Text
nextWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char -> Bool
isLineFeed Char
c)
    let acc' :: [Comment LineFeed]
acc' = [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs [Comment LineFeed]
acc forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
ws
    Maybe (Comment LineFeed)
mbComm <- forall {l}. ParserM ParserErrorType Text (Maybe (Comment l))
comment
    case Maybe (Comment LineFeed)
mbComm of
      Just Comment LineFeed
comm -> [a]
-> [Comment LineFeed]
-> ParserM ParserErrorType Text ([a], [Comment LineFeed])
k1 [a]
trl (Comment LineFeed
comm forall a. a -> [a] -> [a]
: [Comment LineFeed]
acc')
      Maybe (Comment LineFeed)
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse [a]
trl, forall a. [a] -> [a]
reverse [Comment LineFeed]
acc')

  goWs :: [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs [Comment LineFeed]
a (Char
'\r' : Char
'\n' : [Char]
ls) = [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs (forall l. l -> Comment l
Line LineFeed
CRLF forall a. a -> [a] -> [a]
: [Comment LineFeed]
a) [Char]
ls
  goWs [Comment LineFeed]
a (Char
'\r' : [Char]
ls) = [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs (forall l. l -> Comment l
Line LineFeed
CRLF forall a. a -> [a] -> [a]
: [Comment LineFeed]
a) [Char]
ls
  goWs [Comment LineFeed]
a (Char
'\n' : [Char]
ls) = [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs (forall l. l -> Comment l
Line LineFeed
LF forall a. a -> [a] -> [a]
: [Comment LineFeed]
a) [Char]
ls
  goWs [Comment LineFeed]
a (Char
' ' : [Char]
ls) = [Comment LineFeed] -> Int -> [Char] -> [Comment LineFeed]
goSpace [Comment LineFeed]
a Int
1 [Char]
ls
  goWs [Comment LineFeed]
a [Char]
_ = [Comment LineFeed]
a

  goSpace :: [Comment LineFeed] -> Int -> [Char] -> [Comment LineFeed]
goSpace [Comment LineFeed]
a !Int
n (Char
' ' : [Char]
ls) = [Comment LineFeed] -> Int -> [Char] -> [Comment LineFeed]
goSpace [Comment LineFeed]
a (Int
n forall a. Num a => a -> a -> a
+ Int
1) [Char]
ls
  goSpace [Comment LineFeed]
a Int
n [Char]
ls = [Comment LineFeed] -> [Char] -> [Comment LineFeed]
goWs (forall l. Int -> Comment l
Space Int
n forall a. a -> [a] -> [a]
: [Comment LineFeed]
a) [Char]
ls

  isBlockComment :: ParserM e Text (Maybe Bool)
isBlockComment = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> e -> r
_ Text -> Maybe Bool -> r
ksucc ->
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
'-', Text
inp2) ->
        case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
          Just (Char
'-', Text
inp3) ->
            Text -> Maybe Bool -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
          Maybe (Char, Text)
_ ->
            Text -> Maybe Bool -> r
ksucc Text
inp forall a. Maybe a
Nothing
      Just (Char
'{', Text
inp2) ->
        case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
          Just (Char
'-', Text
inp3) ->
            Text -> Maybe Bool -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
          Maybe (Char, Text)
_ ->
            Text -> Maybe Bool -> r
ksucc Text
inp forall a. Maybe a
Nothing
      Maybe (Char, Text)
_ ->
        Text -> Maybe Bool -> r
ksucc Text
inp forall a. Maybe a
Nothing

  comment :: ParserM ParserErrorType Text (Maybe (Comment l))
comment = forall {e}. ParserM e Text (Maybe Bool)
isBlockComment forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Bool
True  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {l}. Text -> ParserM ParserErrorType Text (Comment l)
blockComment Text
"{-"
    Just Bool
False -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {l}. Text -> ParserM ParserErrorType Text (Comment l)
lineComment Text
"--"
    Maybe Bool
Nothing    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  blockComment :: Text -> ParserM ParserErrorType Text (Comment l)
blockComment Text
acc = do
    Text
chs <- (Char -> Bool) -> Lexer Text
nextWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-')
    Text
dashes <- (Char -> Bool) -> Lexer Text
nextWhile (forall a. Eq a => a -> a -> Bool
== Char
'-')
    if Text -> Bool
Text.null Text
dashes
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall l. Text -> Comment l
Comment forall a b. (a -> b) -> a -> b
$ Text
acc forall a. Semigroup a => a -> a -> a
<> Text
chs
      else Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Char
'}' -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall l. Text -> Comment l
Comment (Text
acc forall a. Semigroup a => a -> a -> a
<> Text
chs forall a. Semigroup a => a -> a -> a
<> Text
dashes forall a. Semigroup a => a -> a -> a
<> Text
"}")
        Maybe Char
_ -> Text -> ParserM ParserErrorType Text (Comment l)
blockComment (Text
acc forall a. Semigroup a => a -> a -> a
<> Text
chs forall a. Semigroup a => a -> a -> a
<> Text
dashes)

breakShebang :: ParserM ParserErrorType Text [Comment LineFeed]
breakShebang :: ParserM ParserErrorType Text [Comment LineFeed]
breakShebang = forall {l}. ParserM ParserErrorType Text (Maybe (Comment l))
shebangComment forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just Comment LineFeed
comm -> [Comment LineFeed]
-> ParserM ParserErrorType Text [Comment LineFeed]
k0 [Comment LineFeed
comm]
  Maybe (Comment LineFeed)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
  k0 :: [Comment LineFeed]
-> ParserM ParserErrorType Text [Comment LineFeed]
k0 [Comment LineFeed]
acc = forall {e}. ParserM e Text (Maybe (Comment LineFeed, Text))
lineFeedShebang forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Comment LineFeed
lf, Text
sb) -> do
      Comment LineFeed
comm <- forall {l}. Text -> ParserM ParserErrorType Text (Comment l)
lineComment Text
sb
      [Comment LineFeed]
-> ParserM ParserErrorType Text [Comment LineFeed]
k0 (Comment LineFeed
comm forall a. a -> [a] -> [a]
: Comment LineFeed
lf forall a. a -> [a] -> [a]
: [Comment LineFeed]
acc)
    Maybe (Comment LineFeed, Text)
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Comment LineFeed]
acc

  lineFeedShebang :: ParserM e Text (Maybe (Comment LineFeed, Text))
lineFeedShebang = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> e -> r
_ Text -> Maybe (Comment LineFeed, Text) -> r
ksucc ->
    case Text -> Maybe (Comment LineFeed, Text)
unconsLineFeed Text
inp of
      Just (Comment LineFeed
lf, Text
inp2)
        | Just (Text
sb, Text
inp3) <- Text -> Maybe (Text, Text)
unconsShebang Text
inp2 ->
            Text -> Maybe (Comment LineFeed, Text) -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Comment LineFeed
lf, Text
sb)
      Maybe (Comment LineFeed, Text)
_ ->
        Text -> Maybe (Comment LineFeed, Text) -> r
ksucc Text
inp forall a. Maybe a
Nothing

  unconsLineFeed :: Text -> Maybe (Comment LineFeed, Text)
  unconsLineFeed :: Text -> Maybe (Comment LineFeed, Text)
unconsLineFeed Text
inp =
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
'\r', Text
inp2) ->
        case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
          Just (Char
'\n', Text
inp3) ->
            forall a. a -> Maybe a
Just (forall l. l -> Comment l
Line LineFeed
CRLF, Text
inp3)
          Maybe (Char, Text)
_ ->
            forall a. a -> Maybe a
Just (forall l. l -> Comment l
Line LineFeed
CRLF, Text
inp2)
      Just (Char
'\n', Text
inp2) ->
        forall a. a -> Maybe a
Just (forall l. l -> Comment l
Line LineFeed
LF, Text
inp2)
      Maybe (Char, Text)
_ ->
        forall a. Maybe a
Nothing

  unconsShebang :: Text -> Maybe (Text, Text)
  unconsShebang :: Text -> Maybe (Text, Text)
unconsShebang = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"#!",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
Text.stripPrefix Text
"#!"

  shebangComment :: ParserM ParserErrorType Text (Maybe (Comment lf))
shebangComment = forall {e}. ParserM e Text (Maybe Text)
isShebang forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {l}. Text -> ParserM ParserErrorType Text (Comment l)
lineComment

  isShebang :: ParserM e Text (Maybe Text)
isShebang = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> e -> r
_ Text -> Maybe Text -> r
ksucc ->
    case Text -> Maybe (Text, Text)
unconsShebang Text
inp of
      Just (Text
sb, Text
inp3) ->
        Text -> Maybe Text -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
sb
      Maybe (Text, Text)
_ ->
        Text -> Maybe Text -> r
ksucc Text
inp forall a. Maybe a
Nothing

lineComment :: forall lf. Text -> ParserM ParserErrorType Text (Comment lf)
lineComment :: forall {l}. Text -> ParserM ParserErrorType Text (Comment l)
lineComment Text
acc = do
  Text
comm <- (Char -> Bool) -> Lexer Text
nextWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n')
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall l. Text -> Comment l
Comment (Text
acc forall a. Semigroup a => a -> a -> a
<> Text
comm)

token :: Lexer Token
token :: Lexer Token
token = Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
TokEof) Char -> Lexer Token
k0
  where
  k0 :: Char -> Lexer Token
k0 Char
ch1 = case Char
ch1 of
    Char
'('  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
leftParen
    Char
')'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokRightParen
    Char
'{'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokLeftBrace
    Char
'}'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokRightBrace
    Char
'['  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokLeftSquare
    Char
']'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokRightSquare
    Char
'`'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokTick
    Char
','  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Token
TokComma
    Char
'∷'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 (SourceStyle -> Token
TokDoubleColon SourceStyle
Unicode) Char
ch1
    Char
'←'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 (SourceStyle -> Token
TokLeftArrow SourceStyle
Unicode) Char
ch1
    Char
'→'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 (SourceStyle -> Token
TokRightArrow SourceStyle
Unicode) Char
ch1
    Char
'⇒'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 (SourceStyle -> Token
TokRightFatArrow SourceStyle
Unicode) Char
ch1
    Char
'∀'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 (SourceStyle -> Token
TokForall SourceStyle
Unicode) Char
ch1
    Char
'|'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 Token
TokPipe Char
ch1
    Char
'.'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 Token
TokDot Char
ch1
    Char
'\\' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Lexer Token
orOperator1 Token
TokBackslash Char
ch1
    Char
'<'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Char -> Lexer Token
orOperator2 (SourceStyle -> Token
TokLeftArrow SourceStyle
ASCII) Char
ch1 Char
'-'
    Char
'-'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Char -> Char -> Lexer Token
orOperator2 (SourceStyle -> Token
TokRightArrow SourceStyle
ASCII) Char
ch1 Char
'>'
    Char
'='  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Token -> Char -> Char -> Lexer Token
orOperator2' Token
TokEquals (SourceStyle -> Token
TokRightFatArrow SourceStyle
ASCII) Char
ch1 Char
'>'
    Char
':'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token -> Token -> Char -> Char -> Lexer Token
orOperator2' ([Text] -> Text -> Token
TokOperator [] Text
":") (SourceStyle -> Token
TokDoubleColon SourceStyle
ASCII) Char
ch1 Char
':'
    Char
'?'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
hole
    Char
'\'' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
char
    Char
'"'  -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
string
    Char
_  | Char -> Bool
Char.isDigit Char
ch1 -> forall a. (ParserErrorType -> Bool) -> Lexer a -> Lexer a
restore (forall a. Eq a => a -> a -> Bool
== ParserErrorType
ErrNumberOutOfRange) (Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Lexer Token
number Char
ch1)
       | Char -> Bool
Char.isUpper Char
ch1 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> Char -> Lexer Token
upper [] Char
ch1
       | Char -> Bool
isIdentStart Char
ch1 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> Char -> Lexer Token
lower [] Char
ch1
       | Char -> Bool
isSymbolChar Char
ch1 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1]
       | Bool
otherwise        -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
ch1]) []

  {-# INLINE orOperator1 #-}
  orOperator1 :: Token -> Char -> Lexer Token
  orOperator1 :: Token -> Char -> Lexer Token
orOperator1 Token
tok Char
ch1 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Lexer Token -> r
ksucc ->
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
ch2, Text
inp2) | Char -> Bool
isSymbolChar Char
ch2 ->
        Text -> Lexer Token -> r
ksucc Text
inp2 forall a b. (a -> b) -> a -> b
$ [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1, Char
ch2]
      Maybe (Char, Text)
_ ->
        Text -> Lexer Token -> r
ksucc Text
inp forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
tok

  {-# INLINE orOperator2 #-}
  orOperator2 :: Token -> Char -> Char -> Lexer Token
  orOperator2 :: Token -> Char -> Char -> Lexer Token
orOperator2 Token
tok Char
ch1 Char
ch2 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Lexer Token -> r
ksucc ->
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
ch2', Text
inp2) | Char
ch2 forall a. Eq a => a -> a -> Bool
== Char
ch2' ->
        case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
          Just (Char
ch3, Text
inp3) | Char -> Bool
isSymbolChar Char
ch3 ->
            Text -> Lexer Token -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1, Char
ch2, Char
ch3]
          Maybe (Char, Text)
_ ->
            Text -> Lexer Token -> r
ksucc Text
inp2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
tok
      Maybe (Char, Text)
_ ->
        Text -> Lexer Token -> r
ksucc Text
inp forall a b. (a -> b) -> a -> b
$ [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1]

  {-# INLINE orOperator2' #-}
  orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token
  orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token
orOperator2' Token
tok1 Token
tok2 Char
ch1 Char
ch2 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Lexer Token -> r
ksucc ->
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
ch2', Text
inp2) | Char
ch2 forall a. Eq a => a -> a -> Bool
== Char
ch2' ->
        case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
          Just (Char
ch3, Text
inp3) | Char -> Bool
isSymbolChar Char
ch3 ->
            Text -> Lexer Token -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1, Char
ch2, Char
ch3]
          Maybe (Char, Text)
_ ->
            Text -> Lexer Token -> r
ksucc Text
inp2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
tok2
      Just (Char
ch2', Text
inp2) | Char -> Bool
isSymbolChar Char
ch2' ->
        Text -> Lexer Token -> r
ksucc Text
inp2 forall a b. (a -> b) -> a -> b
$ [Text] -> [Char] -> Lexer Token
operator [] [Char
ch1, Char
ch2']
      Maybe (Char, Text)
_ ->
        Text -> Lexer Token -> r
ksucc Text
inp forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
tok1

  {-
    leftParen
      : '(' '→'  ')'
      | '(' '->' ')'
      | '('  symbolChar+  ')'
      | '('
  -}
  leftParen :: Lexer Token
  leftParen :: Lexer Token
leftParen = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
kerr Text -> Token -> r
ksucc ->
    case (Char -> Bool) -> Text -> (Text, Text)
Text.span Char -> Bool
isSymbolChar Text
inp of
      (Text
chs, Text
inp2)
        | Text -> Bool
Text.null Text
chs -> Text -> Token -> r
ksucc Text
inp Token
TokLeftParen
        | Bool
otherwise ->
            case Text -> Maybe (Char, Text)
Text.uncons Text
inp2 of
              Just (Char
')', Text
inp3) ->
                case Text
chs of
                  Text
"→"  -> Text -> Token -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ SourceStyle -> Token
TokSymbolArr SourceStyle
Unicode
                  Text
"->" -> Text -> Token -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ SourceStyle -> Token
TokSymbolArr SourceStyle
ASCII
                  Text
_ | Text -> Bool
isReservedSymbol Text
chs -> Text -> ParserErrorType -> r
kerr Text
inp ParserErrorType
ErrReservedSymbol
                    | Bool
otherwise -> Text -> Token -> r
ksucc Text
inp3 forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Token
TokSymbolName [] Text
chs
              Maybe (Char, Text)
_ -> Text -> Token -> r
ksucc Text
inp Token
TokLeftParen

  {-
    symbol
      : '(' symbolChar+ ')'
  -}
  symbol :: [Text] -> Lexer Token
  symbol :: [Text] -> Lexer Token
symbol [Text]
qual = forall a. (ParserErrorType -> Bool) -> Lexer a -> Lexer a
restore ParserErrorType -> Bool
isReservedSymbolError forall a b. (a -> b) -> a -> b
$ Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
ch | Char -> Bool
isSymbolChar Char
ch ->
      (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isSymbolChar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
chs ->
        Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Char
')'
            | Text -> Bool
isReservedSymbol Text
chs -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrReservedSymbol
            | Bool
otherwise -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Text] -> Text -> Token
TokSymbolName (forall a. [a] -> [a]
reverse [Text]
qual) Text
chs
          Just Char
ch2 -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
ch2]) []
          Maybe Char
Nothing  -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof
    Just Char
ch -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
ch]) []
    Maybe Char
Nothing -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof

  {-
    operator
      : symbolChar+
  -}
  operator :: [Text] -> String -> Lexer Token
  operator :: [Text] -> [Char] -> Lexer Token
operator [Text]
qual [Char]
pre = do
    Text
rest <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isSymbolChar
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text -> Token
TokOperator (forall a. [a] -> [a]
reverse [Text]
qual) forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
pre forall a. Semigroup a => a -> a -> a
<> Text
rest

  {-
    moduleName
      : upperChar alphaNumChar*

    qualifier
      : (moduleName '.')* moduleName

    upper
      : (qualifier '.')? upperChar identChar*
      | qualifier '.' lowerQualified
      | qualifier '.' operator
      | qualifier '.' symbol
  -}
  upper :: [Text] -> Char -> Lexer Token
  upper :: [Text] -> Char -> Lexer Token
upper [Text]
qual Char
pre = do
    Text
rest <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isIdentChar
    Maybe Char
ch1  <- Lexer (Maybe Char)
peek
    let name :: Text
name = Char -> Text -> Text
Text.cons Char
pre Text
rest
    case Maybe Char
ch1 of
      Just Char
'.' -> do
        let qual' :: [Text]
qual' = Text
name forall a. a -> [a] -> [a]
: [Text]
qual
        Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Char
'(' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> Lexer Token
symbol [Text]
qual'
          Just Char
ch2
            | Char -> Bool
Char.isUpper Char
ch2 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> Char -> Lexer Token
upper [Text]
qual' Char
ch2
            | Char -> Bool
isIdentStart Char
ch2 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> Char -> Lexer Token
lower [Text]
qual' Char
ch2
            | Char -> Bool
isSymbolChar Char
ch2 -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Text] -> [Char] -> Lexer Token
operator [Text]
qual' [Char
ch2]
            | Bool
otherwise -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
ch2]) []
          Maybe Char
Nothing ->
            forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof
      Maybe Char
_ ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Token
TokUpperName (forall a. [a] -> [a]
reverse [Text]
qual) Text
name

  {-
    lower
      : '_'
      | 'forall'
      | lowerChar identChar*

    lowerQualified
      : lowerChar identChar*
  -}
  lower :: [Text] -> Char -> Lexer Token
  lower :: [Text] -> Char -> Lexer Token
lower [Text]
qual Char
pre = do
    Text
rest <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isIdentChar
    case Char
pre of
      Char
'_' | Text -> Bool
Text.null Text
rest ->
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
qual
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
TokUnderscore
          else forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
pre]) []
      Char
_ ->
        case Char -> Text -> Text
Text.cons Char
pre Text
rest of
          Text
"forall" | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
qual -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SourceStyle -> Token
TokForall SourceStyle
ASCII
          Text
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Token
TokLowerName (forall a. [a] -> [a]
reverse [Text]
qual) Text
name

  {-
    hole
      : '?' identChar+
  -}
  hole :: Lexer Token
  hole :: Lexer Token
hole = do
    Text
name <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isIdentChar
    if Text -> Bool
Text.null Text
name
      then [Text] -> [Char] -> Lexer Token
operator [] [Char
'?']
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Token
TokHole Text
name

  {-
    char
      : "'" '\' escape "'"
      | "'" [^'] "'"
  -}
  char :: Lexer Token
  char :: Lexer Token
char = do
    (Text
raw, Char
ch) <- Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Char
'\\' -> do
        (Text
raw, Char
ch2) <- Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserM ParserErrorType Text (Text, Char)
escape
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Text -> Text
Text.cons Char
'\\' Text
raw, Char
ch2)
      Just Char
ch ->
        Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Char -> Text
Text.singleton Char
ch, Char
ch)
      Maybe Char
Nothing ->
        forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof
    Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Char
'\''
        | forall a. Enum a => a -> Int
fromEnum Char
ch forall a. Ord a => a -> a -> Bool
> Int
0xFFFF -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrAstralCodePointInChar
        | Bool
otherwise -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> Char -> Token
TokChar Text
raw Char
ch
      Just Char
ch2 ->
        forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall a. a -> Maybe a
Just [Char
ch2]) []
      Maybe Char
_ ->
        forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof

  {-
    stringPart
      : '\' escape
      | '\' [ \r\n]+ '\'
      | [^"]

    string
      : '"' stringPart* '"'
      | '"""' '"'{0,2} ([^"]+ '"'{1,2})* [^"]* '"""'

    A raw string literal can't contain any sequence of 3 or more quotes,
    although sequences of 1 or 2 quotes are allowed anywhere, including at the
    beginning or the end.
  -}
  string :: Lexer Token
  string :: Lexer Token
string = do
    Text
quotes1 <- Int -> (Char -> Bool) -> Lexer Text
nextWhile' Int
7 (forall a. Eq a => a -> a -> Bool
== Char
'"')
    case Text -> Int
Text.length Text
quotes1 of
      Int
0 -> do
        let
          go :: Text -> DList Char -> Lexer Token
go Text
raw DList Char
acc = do
            Text
chs <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isNormalStringChar
            let
              raw' :: Text
raw' = Text
raw forall a. Semigroup a => a -> a -> a
<> Text
chs
              acc' :: DList Char
acc' = DList Char
acc forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> DList a
DList.fromList (Text -> [Char]
Text.unpack Text
chs)
            Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just Char
'"'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> PSString -> Token
TokString Text
raw' (forall a. IsString a => [Char] -> a
fromString (forall a. DList a -> [a]
DList.toList DList Char
acc'))
              Just Char
'\\' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> DList Char -> Lexer Token
goEscape (Text
raw' forall a. Semigroup a => a -> a -> a
<> Text
"\\") DList Char
acc'
              Just Char
_    -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrLineFeedInString
              Maybe Char
Nothing   -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof

          goEscape :: Text -> DList Char -> Lexer Token
goEscape Text
raw DList Char
acc = do
            Maybe Char
mbCh <- Lexer (Maybe Char)
peek
            case Maybe Char
mbCh of
              Just Char
ch1 | Char -> Bool
isStringGapChar Char
ch1 -> do
                Text
gap <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isStringGapChar
                Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just Char
'"'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> PSString -> Token
TokString (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
gap) (forall a. IsString a => [Char] -> a
fromString (forall a. DList a -> [a]
DList.toList DList Char
acc))
                  Just Char
'\\' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> DList Char -> Lexer Token
go (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
gap forall a. Semigroup a => a -> a -> a
<> Text
"\\") DList Char
acc
                  Just Char
ch   -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Char -> ParserErrorType
ErrCharInGap Char
ch
                  Maybe Char
Nothing   -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof
              Maybe Char
_ -> do
                (Text
raw', Char
ch) <- ParserM ParserErrorType Text (Text, Char)
escape
                Text -> DList Char -> Lexer Token
go (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
raw') (DList Char
acc forall a. Semigroup a => a -> a -> a
<> forall a. a -> DList a
DList.singleton Char
ch)
        Text -> DList Char -> Lexer Token
go Text
"" forall a. Monoid a => a
mempty
      Int
1 ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> PSString -> Token
TokString Text
"" PSString
""
      Int
n | Int
n forall a. Ord a => a -> a -> Bool
>= Int
5 ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Token
TokRawString forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
5 Text
quotes1
      Int
_ -> do
        let
          go :: Text -> Lexer Token
go Text
acc = do
            Text
chs <- (Char -> Bool) -> Lexer Text
nextWhile (forall a. Eq a => a -> a -> Bool
/= Char
'"')
            Text
quotes2 <- Int -> (Char -> Bool) -> Lexer Text
nextWhile' Int
5 (forall a. Eq a => a -> a -> Bool
== Char
'"')
            case Text -> Int
Text.length Text
quotes2 of
              Int
0          -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrEof
              Int
n | Int
n forall a. Ord a => a -> a -> Bool
>= Int
3 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Token
TokRawString forall a b. (a -> b) -> a -> b
$ Text
acc forall a. Semigroup a => a -> a -> a
<> Text
chs forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.drop Int
3 Text
quotes2
              Int
_          -> Text -> Lexer Token
go (Text
acc forall a. Semigroup a => a -> a -> a
<> Text
chs forall a. Semigroup a => a -> a -> a
<> Text
quotes2)
        Text -> Lexer Token
go forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
2 Text
quotes1

  {-
    escape
      : 't'
      | 'r'
      | 'n'
      | "'"
      | '"'
      | 'x' [0-9a-fA-F]{0,6}
  -}
  escape :: Lexer (Text, Char)
  escape :: ParserM ParserErrorType Text (Text, Char)
escape = do
    Maybe Char
ch <- Lexer (Maybe Char)
peek
    case Maybe Char
ch of
      Just Char
't'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"t", Char
'\t')
      Just Char
'r'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"r", Char
'\r')
      Just Char
'n'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"n", Char
'\n')
      Just Char
'"'  -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"\"", Char
'"')
      Just Char
'\'' -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"'", Char
'\'')
      Just Char
'\\' -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"\\", Char
'\\')
      Just Char
'x'  -> forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) Lexer ()
next forall a b. (a -> b) -> a -> b
$ forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
kerr Text -> (Text, Char) -> r
ksucc -> do
        let
          go :: Int -> [Char] -> [Char] -> r
go Int
n [Char]
acc (Char
ch' : [Char]
chs)
            | Char -> Bool
Char.isHexDigit Char
ch' = Int -> [Char] -> [Char] -> r
go (Int
n forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ Char -> Int
Char.digitToInt Char
ch') (Char
ch' forall a. a -> [a] -> [a]
: [Char]
acc) [Char]
chs
          go Int
n [Char]
acc [Char]
_
            | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF =
                Text -> (Text, Char) -> r
ksucc (Int -> Text -> Text
Text.drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
acc) Text
inp)
                  (Text
"x" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. [a] -> [a]
reverse [Char]
acc), Int -> Char
Char.chr Int
n)
            | Bool
otherwise =
                Text -> ParserErrorType -> r
kerr Text
inp ParserErrorType
ErrCharEscape -- TODO
        Int -> [Char] -> [Char] -> r
go Int
0 [] forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.take Int
6 Text
inp
      Maybe Char
_ -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrCharEscape

  {-
    number
      : hexadecimal
      | integer ('.'  fraction)? exponent?
  -}
  number :: Char -> Lexer Token
  number :: Char -> Lexer Token
number Char
ch1 = Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Char
ch2 -> case (Char
ch1, Maybe Char
ch2) of
    (Char
'0', Just Char
'x') -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
hexadecimal
    (Char
_, Maybe Char
_) -> do
      Maybe (Text, [Char])
mbInt <- Char -> Lexer (Maybe (Text, [Char]))
integer1 Char
ch1
      Maybe (Text, [Char])
mbFraction <- Lexer (Maybe (Text, [Char]))
fraction
      case (Maybe (Text, [Char])
mbInt, Maybe (Text, [Char])
mbFraction) of
        (Just (Text
raw, [Char]
int), Maybe (Text, [Char])
Nothing) -> do
          let int' :: Integer
int' = [Char] -> Integer
digitsToInteger [Char]
int
          Lexer (Maybe (Text, Int))
exponent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (Text
raw', Int
exp) ->
              Text -> Scientific -> Lexer Token
sciDouble (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
raw') forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Scientific
Sci.scientific Integer
int' Int
exp
            Maybe (Text, Int)
Nothing ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Integer -> Token
TokInt Text
raw Integer
int'
        (Just (Text
raw, [Char]
int), Just (Text
raw', [Char]
frac)) -> do
          let sci :: (Integer, Int)
sci = [Char] -> [Char] -> (Integer, Int)
digitsToScientific [Char]
int [Char]
frac
          Lexer (Maybe (Text, Int))
exponent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (Text
raw'', Int
exp) ->
              Text -> Scientific -> Lexer Token
sciDouble (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
raw' forall a. Semigroup a => a -> a -> a
<> Text
raw'') forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Integer -> Int -> Scientific
Sci.scientific forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a -> a
+ Int
exp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Int)
sci
            Maybe (Text, Int)
Nothing ->
              Text -> Scientific -> Lexer Token
sciDouble (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
raw') forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Integer -> Int -> Scientific
Sci.scientific (Integer, Int)
sci
        (Maybe (Text, [Char])
Nothing, Just (Text
raw, [Char]
frac)) -> do
          let sci :: (Integer, Int)
sci = [Char] -> [Char] -> (Integer, Int)
digitsToScientific [] [Char]
frac
          Lexer (Maybe (Text, Int))
exponent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (Text
raw', Int
exp) ->
              Text -> Scientific -> Lexer Token
sciDouble (Text
raw forall a. Semigroup a => a -> a -> a
<> Text
raw') forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Integer -> Int -> Scientific
Sci.scientific forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a -> a
+ Int
exp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Int)
sci
            Maybe (Text, Int)
Nothing ->
              Text -> Scientific -> Lexer Token
sciDouble Text
raw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Integer -> Int -> Scientific
Sci.scientific (Integer, Int)
sci
        (Maybe (Text, [Char])
Nothing, Maybe (Text, [Char])
Nothing) ->
          Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Char
ch -> forall e s a. e -> ParserM e s a
throw forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [[Char]] -> ParserErrorType
ErrLexeme (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Char
ch) []

  sciDouble :: Text -> Sci.Scientific -> Lexer Token
  sciDouble :: Text -> Scientific -> Lexer Token
sciDouble Text
raw Scientific
sci = case forall a. RealFloat a => Scientific -> Either a a
Sci.toBoundedRealFloat Scientific
sci of
    Left Double
_ -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrNumberOutOfRange
    Right Double
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Double -> Token
TokNumber Text
raw Double
n

  {-
    integer
      : '0'
      | [1-9] digits
  -}
  integer :: Lexer (Maybe (Text, String))
  integer :: Lexer (Maybe (Text, [Char]))
integer = Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
'0' -> Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Char
ch | Char -> Bool
isNumberChar Char
ch -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrLeadingZero
      Maybe Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
"0", [Char]
"0")
    Just Char
ch | Char -> Bool
Char.isDigit Char
ch -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer (Text, [Char])
digits
    Maybe Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  {-
    integer1
      : '0'
      | [1-9] digits

    This is the same as 'integer', the only difference is that this expects the
    first char to be consumed during dispatch.
  -}
  integer1 :: Char -> Lexer (Maybe (Text, String))
  integer1 :: Char -> Lexer (Maybe (Text, [Char]))
integer1 = \case
    Char
'0' -> Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Char
ch | Char -> Bool
isNumberChar Char
ch -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrLeadingZero
      Maybe Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
"0", [Char]
"0")
    Char
ch | Char -> Bool
Char.isDigit Char
ch -> do
      (Text
raw, [Char]
chs) <- Lexer (Text, [Char])
digits
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Char -> Text -> Text
Text.cons Char
ch Text
raw, Char
ch forall a. a -> [a] -> [a]
: [Char]
chs)
    Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  {-
    fraction
      : '.' [0-9_]+
  -}
  fraction :: Lexer (Maybe (Text, String))
  fraction :: Lexer (Maybe (Text, [Char]))
fraction = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \Text
inp Text -> ParserErrorType -> r
_ Text -> Maybe (Text, [Char]) -> r
ksucc ->
    -- We need more than a single char lookahead for things like `1..10`.
    case Text -> Maybe (Char, Text)
Text.uncons Text
inp of
      Just (Char
'.', Text
inp')
        | (Text
raw, Text
inp'') <- (Char -> Bool) -> Text -> (Text, Text)
Text.span Char -> Bool
isNumberChar Text
inp'
        , Bool -> Bool
not (Text -> Bool
Text.null Text
raw) ->
            Text -> Maybe (Text, [Char]) -> r
ksucc Text
inp'' forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
"." forall a. Semigroup a => a -> a -> a
<> Text
raw, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'_') forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
raw)
      Maybe (Char, Text)
_ ->
        Text -> Maybe (Text, [Char]) -> r
ksucc Text
inp forall a. Maybe a
Nothing

  {-
    digits
      : [0-9_]*

    Digits can contain underscores, which are ignored.
  -}
  digits :: Lexer (Text, String)
  digits :: Lexer (Text, [Char])
digits = do
    Text
raw <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
isNumberChar
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
raw, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'_') forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
raw)

  {-
    exponent
      : 'e' ('+' | '-')? integer
  -}
  exponent :: Lexer (Maybe (Text, Int))
  exponent :: Lexer (Maybe (Text, Int))
exponent = Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
'e' -> do
      (Bool
neg, Text
sign) <- Lexer ()
next forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer (Maybe Char)
peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Char
'-' -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Bool
True, Text
"-")
        Just Char
'+' -> Lexer ()
next forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Bool
False, Text
"+")
        Maybe Char
_   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Text
"")
      Lexer (Maybe (Text, [Char]))
integer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Text
raw, [Char]
chs) -> do
          let
            int :: Integer
int | Bool
neg = forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ [Char] -> Integer
digitsToInteger [Char]
chs
                | Bool
otherwise = [Char] -> Integer
digitsToInteger [Char]
chs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
"e" forall a. Semigroup a => a -> a -> a
<> Text
sign forall a. Semigroup a => a -> a -> a
<> Text
raw, forall a. Num a => Integer -> a
fromInteger Integer
int)
        Maybe (Text, [Char])
Nothing -> forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrExpectedExponent
    Maybe Char
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  {-
    hexadecimal
      : '0x' [0-9a-fA-F]+
  -}
  hexadecimal :: Lexer Token
  hexadecimal :: Lexer Token
hexadecimal = do
    Text
chs <- (Char -> Bool) -> Lexer Text
nextWhile Char -> Bool
Char.isHexDigit
    if Text -> Bool
Text.null Text
chs
      then forall e s a. e -> ParserM e s a
throw ParserErrorType
ErrExpectedHex
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Integer -> Token
TokInt (Text
"0x" forall a. Semigroup a => a -> a -> a
<> Text
chs) forall a b. (a -> b) -> a -> b
$ Integer -> [Char] -> Integer
digitsToIntegerBase Integer
16 forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack Text
chs

digitsToInteger :: String -> Integer
digitsToInteger :: [Char] -> Integer
digitsToInteger = Integer -> [Char] -> Integer
digitsToIntegerBase Integer
10

digitsToIntegerBase :: Integer -> String -> Integer
digitsToIntegerBase :: Integer -> [Char] -> Integer
digitsToIntegerBase Integer
b = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Integer
n Char
c -> Integer
n forall a. Num a => a -> a -> a
* Integer
b forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Integer
toInteger (Char -> Int
Char.digitToInt Char
c)) Integer
0

digitsToScientific :: String -> String -> (Integer, Int)
digitsToScientific :: [Char] -> [Char] -> (Integer, Int)
digitsToScientific = forall {t}. Num t => t -> [Char] -> [Char] -> (Integer, t)
go Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
  go :: t -> [Char] -> [Char] -> (Integer, t)
go !t
exp [Char]
is [] = ([Char] -> Integer
digitsToInteger (forall a. [a] -> [a]
reverse [Char]
is), t
exp)
  go t
exp [Char]
is (Char
f : [Char]
fs) = t -> [Char] -> [Char] -> (Integer, t)
go (t
exp forall a. Num a => a -> a -> a
- t
1) (Char
f forall a. a -> [a] -> [a]
: [Char]
is) [Char]
fs

isSymbolChar :: Char -> Bool
isSymbolChar :: Char -> Bool
isSymbolChar Char
c = (Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
":!#$%&*+./<=>?@\\^|-~" :: String)) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Char -> Bool
Char.isAscii Char
c) Bool -> Bool -> Bool
&& Char -> Bool
Char.isSymbol Char
c)

isReservedSymbolError :: ParserErrorType -> Bool
isReservedSymbolError :: ParserErrorType -> Bool
isReservedSymbolError = (forall a. Eq a => a -> a -> Bool
== ParserErrorType
ErrReservedSymbol)

isReservedSymbol :: Text -> Bool
isReservedSymbol :: Text -> Bool
isReservedSymbol = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Text]
symbols
  where
  symbols :: [Text]
symbols =
    [ Text
"::"
    , Text
"∷"
    , Text
"<-"
    , Text
"←"
    , Text
"->"
    , Text
"→"
    , Text
"=>"
    , Text
"⇒"
    , Text
"∀"
    , Text
"|"
    , Text
"."
    , Text
"\\"
    , Text
"="
    ]

isIdentStart :: Char -> Bool
isIdentStart :: Char -> Bool
isIdentStart Char
c = Char -> Bool
Char.isLower Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'

isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar Char
c = Char -> Bool
Char.isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''

isNumberChar :: Char -> Bool
isNumberChar :: Char -> Bool
isNumberChar Char
c = Char -> Bool
Char.isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'

isNormalStringChar :: Char -> Bool
isNormalStringChar :: Char -> Bool
isNormalStringChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n'

isStringGapChar :: Char -> Bool
isStringGapChar :: Char -> Bool
isStringGapChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'

isLineFeed :: Char -> Bool
isLineFeed :: Char -> Bool
isLineFeed Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'

-- | Checks if some identifier is a valid unquoted key.
isUnquotedKey :: Text -> Bool
isUnquotedKey :: Text -> Bool
isUnquotedKey Text
t =
  case Text -> Maybe (Char, Text)
Text.uncons Text
t of
    Maybe (Char, Text)
Nothing ->
      Bool
False
    Just (Char
hd, Text
tl) ->
      Char -> Bool
isIdentStart Char
hd Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isIdentChar Text
tl