module Language.PureScript.CST.Lexer
( lenient
, lexModule
, lex
, lexTopLevel
, lexWithState
, isUnquotedKey
) where
import Prelude hiding (lex, exp, exponent, lines)
import Control.Monad (join)
import Data.Char qualified as Char
import Data.DList qualified as DList
import Data.Foldable (foldl')
import Data.Functor (($>))
import Data.Scientific qualified as Sci
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.PureScript qualified as Text
import Language.PureScript.CST.Errors (ParserErrorInfo(..), ParserErrorType(..))
import Language.PureScript.CST.Monad (LexResult, LexState(..), ParserM(..), throw)
import Language.PureScript.CST.Layout (LayoutDelim(..), insertLayout, lytToken, unwindLayout)
import Language.PureScript.CST.Positions (advanceLeading, advanceToken, advanceTrailing, applyDelta, textDelta)
import Language.PureScript.CST.Types (Comment(..), LineFeed(..), SourcePos(..), SourceRange(..), SourceStyle(..), SourceToken(..), Token(..), TokenAnn(..))
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
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)]
}
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
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)
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)
= \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])
= 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)
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 :: 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 :: [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 :: [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
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 :: [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 :: 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 :: 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
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 :: 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
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 :: 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 :: 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 :: 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 :: 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 ->
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 :: 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 :: 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 :: 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'
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