Lexer.hs

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(..))

-- | 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 = go
  where
  go [] = []
  go (Right a : as) = Right a : go as
  go (Left (st, _) : _) = do
    let
      pos = lexPos st
      ann = TokenAnn (SourceRange pos pos) (lexLeading st) []
    [Right (SourceToken ann TokEof)]

lexModule :: Text -> [LexResult]
lexModule = lex' shebangThenComments

-- | Lexes according to root layout rules.
lex :: Text -> [LexResult]
lex = lex' comments

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

  lexWithState $ LexState
    { lexPos = advanceLeading (SourcePos 1 1) leading
    , lexLeading = leading
    , lexSource = src'
    , lexStack = [(SourcePos 0 0, LytRoot)]
    }

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

-- | Lexes according to some LexState.
lexWithState :: LexState -> [LexResult]
lexWithState = go
  where
  Parser lexK =
    tokenAndComments

  go state@LexState {..} =
    lexK lexSource onError onSuccess
    where
    onError lexSource' err = do
      let
        len1 = Text.length lexSource
        len2 = Text.length lexSource'
        chunk = Text.take (max 0 (len1 - len2)) lexSource
        chunkDelta = textDelta chunk
        pos = applyDelta lexPos chunkDelta
      pure $ Left
        ( state { lexSource = lexSource' }
        , ParserErrorInfo (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err
        )

    onSuccess _ (TokEof, _) =
      Right <$> unwindLayout lexPos lexLeading lexStack
    onSuccess lexSource' (tok, (trailing, lexLeading')) = do
      let
        endPos = advanceToken lexPos tok
        lexPos' = advanceLeading (advanceTrailing endPos trailing) lexLeading'
        tokenAnn = TokenAnn
          { tokRange = SourceRange lexPos endPos
          , tokLeadingComments = lexLeading
          , tokTrailingComments = trailing
          }
        (lexStack', toks) =
          insertLayout (SourceToken tokenAnn tok) lexPos' lexStack
        state' = LexState
          { lexPos = lexPos'
          , lexLeading = lexLeading'
          , lexSource = lexSource'
          , lexStack = lexStack'
          }
      go2 state' toks

  go2 state [] = go state
  go2 state (t : ts) = Right t : go2 state ts

type Lexer = ParserM ParserErrorType Text

{-# INLINE next #-}
next :: Lexer ()
next = Parser $ \inp _ ksucc ->
  ksucc (Text.drop 1 inp) ()

{-# INLINE nextWhile #-}
nextWhile :: (Char -> Bool) -> Lexer Text
nextWhile p = Parser $ \inp _ ksucc -> do
  let (chs, inp') = Text.span p inp
  ksucc inp' chs

{-# INLINE nextWhile' #-}
nextWhile' :: Int -> (Char -> Bool) -> Lexer Text
nextWhile' n p = Parser $ \inp _ ksucc -> do
  let (chs, inp') = Text.spanUpTo n p inp
  ksucc inp' chs

{-# INLINE peek #-}
peek :: Lexer (Maybe Char)
peek = Parser $ \inp _ ksucc ->
  if Text.null inp
    then ksucc inp Nothing
    else ksucc inp $ Just $ Text.head inp

{-# INLINE restore #-}
restore :: (ParserErrorType -> Bool) -> Lexer a -> Lexer a
restore p (Parser k) = Parser $ \inp kerr ksucc ->
  k inp (\inp' err -> kerr (if p err then inp else inp') err) ksucc

tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed]))
tokenAndComments = (,) <$> token <*> breakComments

shebangThenComments :: Text -> ([Comment LineFeed], Text)
shebangThenComments src = do
  let
    (sb, (coms, src')) = comments <$> shebang src
  (sb <> coms, src')

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

comments :: Text -> ([Comment LineFeed], Text)
comments = \src -> k src (\_ _ -> ([], src)) (\inp (a, b) -> (a <> b, inp))
  where
  Parser k = breakComments

breakComments :: Lexer ([Comment void], [Comment LineFeed])
breakComments = k0 []
  where
  k0 acc = do
    spaces <- nextWhile (== ' ')
    lines  <- nextWhile isLineFeed
    let
      acc'
        | Text.null spaces = acc
        | otherwise = Space (Text.length spaces) : acc
    if Text.null lines
      then do
        mbComm <- comment
        case mbComm of
          Just comm -> k0 (comm : acc')
          Nothing   -> pure (reverse acc', [])
      else
        k1 acc' (goWs [] $ Text.unpack lines)

  k1 trl acc = do
    ws <- nextWhile (\c -> c == ' ' || isLineFeed c)
    let acc' = goWs acc $ Text.unpack ws
    mbComm <- comment
    case mbComm of
      Just comm -> k1 trl (comm : acc')
      Nothing   -> pure (reverse trl, reverse acc')

  goWs a ('\r' : '\n' : ls) = goWs (Line CRLF : a) ls
  goWs a ('\r' : ls) = goWs (Line CRLF : a) ls
  goWs a ('\n' : ls) = goWs (Line LF : a) ls
  goWs a (' ' : ls) = goSpace a 1 ls
  goWs a _ = a

  goSpace a !n (' ' : ls) = goSpace a (n + 1) ls
  goSpace a n ls = goWs (Space n : a) ls

  isBlockComment = Parser $ \inp _ ksucc ->
    case Text.uncons inp of
      Just ('-', inp2) ->
        case Text.uncons inp2 of
          Just ('-', inp3) ->
            ksucc inp3 $ Just False
          _ ->
            ksucc inp Nothing
      Just ('{', inp2) ->
        case Text.uncons inp2 of
          Just ('-', inp3) ->
            ksucc inp3 $ Just True
          _ ->
            ksucc inp Nothing
      _ ->
        ksucc inp Nothing

  comment = isBlockComment >>= \case
    Just True  -> Just <$> blockComment "{-"
    Just False -> Just <$> lineComment "--"
    Nothing    -> pure Nothing

  blockComment acc = do
    chs <- nextWhile (/= '-')
    dashes <- nextWhile (== '-')
    if Text.null dashes
      then pure $ Comment $ acc <> chs
      else peek >>= \case
        Just '}' -> next $> Comment (acc <> chs <> dashes <> "}")
        _ -> blockComment (acc <> chs <> dashes)

breakShebang :: ParserM ParserErrorType Text [Comment LineFeed]
breakShebang = shebangComment >>= \case
  Just comm -> k0 [comm]
  Nothing -> pure []
  where
  k0 acc = lineFeedShebang >>= \case
    Just (lf, sb) -> do
      comm <- lineComment sb
      k0 (comm : lf : acc)
    Nothing ->
      pure $ reverse acc

  lineFeedShebang = Parser $ \inp _ ksucc ->
    case unconsLineFeed inp of
      Just (lf, inp2)
        | Just (sb, inp3) <- unconsShebang inp2 ->
            ksucc inp3 $ Just (lf, sb)
      _ ->
        ksucc inp Nothing

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

  unconsShebang :: Text -> Maybe (Text, Text)
  unconsShebang = fmap ("#!",) . Text.stripPrefix "#!"

  shebangComment = isShebang >>= traverse lineComment

  isShebang = Parser $ \inp _ ksucc ->
    case unconsShebang inp of
      Just (sb, inp3) ->
        ksucc inp3 $ Just sb
      _ ->
        ksucc inp Nothing

lineComment :: forall lf. Text -> ParserM ParserErrorType Text (Comment lf)
lineComment acc = do
  comm <- nextWhile (\c -> c /= '\r' && c /= '\n')
  pure $ Comment (acc <> comm)

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

  {-# INLINE orOperator1 #-}
  orOperator1 :: Token -> Char -> Lexer Token
  orOperator1 tok ch1 = join $ Parser $ \inp _ ksucc ->
    case Text.uncons inp of
      Just (ch2, inp2) | isSymbolChar ch2 ->
        ksucc inp2 $ operator [] [ch1, ch2]
      _ ->
        ksucc inp $ pure tok

  {-# INLINE orOperator2 #-}
  orOperator2 :: Token -> Char -> Char -> Lexer Token
  orOperator2 tok ch1 ch2 = join $ Parser $ \inp _ ksucc ->
    case Text.uncons inp of
      Just (ch2', inp2) | ch2 == ch2' ->
        case Text.uncons inp2 of
          Just (ch3, inp3) | isSymbolChar ch3 ->
            ksucc inp3 $ operator [] [ch1, ch2, ch3]
          _ ->
            ksucc inp2 $ pure tok
      _ ->
        ksucc inp $ operator [] [ch1]

  {-# INLINE orOperator2' #-}
  orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token
  orOperator2' tok1 tok2 ch1 ch2 = join $ Parser $ \inp _ ksucc ->
    case Text.uncons inp of
      Just (ch2', inp2) | ch2 == ch2' ->
        case Text.uncons inp2 of
          Just (ch3, inp3) | isSymbolChar ch3 ->
            ksucc inp3 $ operator [] [ch1, ch2, ch3]
          _ ->
            ksucc inp2 $ pure tok2
      Just (ch2', inp2) | isSymbolChar ch2' ->
        ksucc inp2 $ operator [] [ch1, ch2']
      _ ->
        ksucc inp $ pure tok1

  {-
    leftParen
      : '(' '→'  ')'
      | '(' '->' ')'
      | '('  symbolChar+  ')'
      | '('
  -}
  leftParen :: Lexer Token
  leftParen = Parser $ \inp kerr ksucc ->
    case Text.span isSymbolChar inp of
      (chs, inp2)
        | Text.null chs -> ksucc inp TokLeftParen
        | otherwise ->
            case Text.uncons inp2 of
              Just (')', inp3) ->
                case chs of
                  "→"  -> ksucc inp3 $ TokSymbolArr Unicode
                  "->" -> ksucc inp3 $ TokSymbolArr ASCII
                  _ | isReservedSymbol chs -> kerr inp ErrReservedSymbol
                    | otherwise -> ksucc inp3 $ TokSymbolName [] chs
              _ -> ksucc inp TokLeftParen

  {-
    symbol
      : '(' symbolChar+ ')'
  -}
  symbol :: [Text] -> Lexer Token
  symbol qual = restore isReservedSymbolError $ peek >>= \case
    Just ch | isSymbolChar ch ->
      nextWhile isSymbolChar >>= \chs ->
        peek >>= \case
          Just ')'
            | isReservedSymbol chs -> throw ErrReservedSymbol
            | otherwise -> next $> TokSymbolName (reverse qual) chs
          Just ch2 -> throw $ ErrLexeme (Just [ch2]) []
          Nothing  -> throw ErrEof
    Just ch -> throw $ ErrLexeme (Just [ch]) []
    Nothing -> throw ErrEof

  {-
    operator
      : symbolChar+
  -}
  operator :: [Text] -> String -> Lexer Token
  operator qual pre = do
    rest <- nextWhile isSymbolChar
    pure . TokOperator (reverse qual) $ Text.pack pre <> rest

  {-
    moduleName
      : upperChar alphaNumChar*

    qualifier
      : (moduleName '.')* moduleName

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

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

    lowerQualified
      : lowerChar identChar*
  -}
  lower :: [Text] -> Char -> Lexer Token
  lower qual pre = do
    rest <- nextWhile isIdentChar
    case pre of
      '_' | Text.null rest ->
        if null qual
          then pure TokUnderscore
          else throw $ ErrLexeme (Just [pre]) []
      _ ->
        case Text.cons pre rest of
          "forall" | null qual -> pure $ TokForall ASCII
          name -> pure $ TokLowerName (reverse qual) name

  {-
    hole
      : '?' identChar+
  -}
  hole :: Lexer Token
  hole = do
    name <- nextWhile isIdentChar
    if Text.null name
      then operator [] ['?']
      else pure $ TokHole name

  {-
    char
      : "'" '\' escape "'"
      | "'" [^'] "'"
  -}
  char :: Lexer Token
  char = do
    (raw, ch) <- peek >>= \case
      Just '\\' -> do
        (raw, ch2) <- next *> escape
        pure (Text.cons '\\' raw, ch2)
      Just ch ->
        next $> (Text.singleton ch, ch)
      Nothing ->
        throw ErrEof
    peek >>= \case
      Just '\''
        | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar
        | otherwise -> next $> TokChar raw ch
      Just ch2 ->
        throw $ ErrLexeme (Just [ch2]) []
      _ ->
        throw 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 = do
    quotes1 <- nextWhile' 7 (== '"')
    case Text.length quotes1 of
      0 -> do
        let
          go raw acc = do
            chs <- nextWhile isNormalStringChar
            let
              raw' = raw <> chs
              acc' = acc <> DList.fromList (Text.unpack chs)
            peek >>= \case
              Just '"'  -> next $> TokString raw' (fromString (DList.toList acc'))
              Just '\\' -> next *> goEscape (raw' <> "\\") acc'
              Just _    -> throw ErrLineFeedInString
              Nothing   -> throw ErrEof

          goEscape raw acc = do
            mbCh <- peek
            case mbCh of
              Just ch1 | isStringGapChar ch1 -> do
                gap <- nextWhile isStringGapChar
                peek >>= \case
                  Just '"'  -> next $> TokString (raw <> gap) (fromString (DList.toList acc))
                  Just '\\' -> next *> go (raw <> gap <> "\\") acc
                  Just ch   -> throw $ ErrCharInGap ch
                  Nothing   -> throw ErrEof
              _ -> do
                (raw', ch) <- escape
                go (raw <> raw') (acc <> DList.singleton ch)
        go "" mempty
      1 ->
        pure $ TokString "" ""
      n | n >= 5 ->
        pure $ TokRawString $ Text.drop 5 quotes1
      _ -> do
        let
          go acc = do
            chs <- nextWhile (/= '"')
            quotes2 <- nextWhile' 5 (== '"')
            case Text.length quotes2 of
              0          -> throw ErrEof
              n | n >= 3 -> pure $ TokRawString $ acc <> chs <> Text.drop 3 quotes2
              _          -> go (acc <> chs <> quotes2)
        go $ Text.drop 2 quotes1

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

  {-
    number
      : hexadecimal
      | integer ('.'  fraction)? exponent?
  -}
  number :: Char -> Lexer Token
  number ch1 = peek >>= \ch2 -> case (ch1, ch2) of
    ('0', Just 'x') -> next *> hexadecimal
    (_, _) -> do
      mbInt <- integer1 ch1
      mbFraction <- fraction
      case (mbInt, mbFraction) of
        (Just (raw, int), Nothing) -> do
          let int' = digitsToInteger int
          exponent >>= \case
            Just (raw', exp) ->
              sciDouble (raw <> raw') $ Sci.scientific int' exp
            Nothing ->
              pure $ TokInt raw int'
        (Just (raw, int), Just (raw', frac)) -> do
          let sci = digitsToScientific int frac
          exponent >>= \case
            Just (raw'', exp) ->
              sciDouble (raw <> raw' <> raw'') $ uncurry Sci.scientific $ (+ exp) <$> sci
            Nothing ->
              sciDouble (raw <> raw') $ uncurry Sci.scientific sci
        (Nothing, Just (raw, frac)) -> do
          let sci = digitsToScientific [] frac
          exponent >>= \case
            Just (raw', exp) ->
              sciDouble (raw <> raw') $ uncurry Sci.scientific $ (+ exp) <$> sci
            Nothing ->
              sciDouble raw $ uncurry Sci.scientific sci
        (Nothing, Nothing) ->
          peek >>= \ch -> throw $ ErrLexeme (pure <$> ch) []

  sciDouble :: Text -> Sci.Scientific -> Lexer Token
  sciDouble raw sci = case Sci.toBoundedRealFloat sci of
    Left _ -> throw ErrNumberOutOfRange
    Right n -> pure $ TokNumber raw n

  {-
    integer
      : '0'
      | [1-9] digits
  -}
  integer :: Lexer (Maybe (Text, String))
  integer = peek >>= \case
    Just '0' -> next *> peek >>= \case
      Just ch | isNumberChar ch -> throw ErrLeadingZero
      _ -> pure $ Just ("0", "0")
    Just ch | Char.isDigit ch -> Just <$> digits
    _ -> pure 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 = \case
    '0' -> peek >>= \case
      Just ch | isNumberChar ch -> throw ErrLeadingZero
      _ -> pure $ Just ("0", "0")
    ch | Char.isDigit ch -> do
      (raw, chs) <- digits
      pure $ Just (Text.cons ch raw, ch : chs)
    _ -> pure Nothing

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

  {-
    digits
      : [0-9_]*

    Digits can contain underscores, which are ignored.
  -}
  digits :: Lexer (Text, String)
  digits = do
    raw <- nextWhile isNumberChar
    pure (raw, filter (/= '_') $ Text.unpack raw)

  {-
    exponent
      : 'e' ('+' | '-')? integer
  -}
  exponent :: Lexer (Maybe (Text, Int))
  exponent = peek >>= \case
    Just 'e' -> do
      (neg, sign) <- next *> peek >>= \case
        Just '-' -> next $> (True, "-")
        Just '+' -> next $> (False, "+")
        _   -> pure (False, "")
      integer >>= \case
        Just (raw, chs) -> do
          let
            int | neg = negate $ digitsToInteger chs
                | otherwise = digitsToInteger chs
          pure $ Just ("e" <> sign <> raw, fromInteger int)
        Nothing -> throw ErrExpectedExponent
    _ ->
      pure Nothing

  {-
    hexadecimal
      : '0x' [0-9a-fA-F]+
  -}
  hexadecimal :: Lexer Token
  hexadecimal = do
    chs <- nextWhile Char.isHexDigit
    if Text.null chs
      then throw ErrExpectedHex
      else pure $ TokInt ("0x" <> chs) $ digitsToIntegerBase 16 $ Text.unpack chs

digitsToInteger :: String -> Integer
digitsToInteger = digitsToIntegerBase 10

digitsToIntegerBase :: Integer -> String -> Integer
digitsToIntegerBase b = foldl' (\n c -> n * b + toInteger (Char.digitToInt c)) 0

digitsToScientific :: String -> String -> (Integer, Int)
digitsToScientific = go 0 . reverse
  where
  go !exp is [] = (digitsToInteger (reverse is), exp)
  go exp is (f : fs) = go (exp - 1) (f : is) fs

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

isReservedSymbolError :: ParserErrorType -> Bool
isReservedSymbolError = (== ErrReservedSymbol)

isReservedSymbol :: Text -> Bool
isReservedSymbol = flip elem symbols
  where
  symbols =
    [ "::"
    , "∷"
    , "<-"
    , "←"
    , "->"
    , "→"
    , "=>"
    , "⇒"
    , "∀"
    , "|"
    , "."
    , "\\"
    , "="
    ]

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

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

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

isNormalStringChar :: Char -> Bool
isNormalStringChar c = c /= '"' && c /= '\\' && c /= '\r' && c /= '\n'

isStringGapChar :: Char -> Bool
isStringGapChar c = c == ' ' || c == '\r' || c == '\n'

isLineFeed :: Char -> Bool
isLineFeed c = c == '\r' || c == '\n'

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