{- |
    Module      :  $Header$
    Description :  A lexer for Curry
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2011 - 2013 Björn Peemöller
                       2016        Finn Teegen
                       2016        Jan Tikovsky
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable
-}
module Curry.Syntax.Lexer
  ( -- * Data types for tokens
    Token (..), Category (..), Attributes (..)

    -- * lexing functions
  , lexSource, lexer, fullLexer
  ) where

import Prelude hiding (fail)
import Data.Char
  ( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit
  , isSpace, isUpper, toLower
  )
import Data.List (intercalate)
import qualified Data.Map as Map
  (Map, union, lookup, findWithDefault, fromList)

import Curry.Base.LexComb
import Curry.Base.Position
import Curry.Base.Span

-- ---------------------------------------------------------------------------
-- Tokens. Note that the equality and ordering instances of Token disregard
-- the attributes, as so that the parser decides about accepting a token
-- just by its category.
-- ---------------------------------------------------------------------------

-- |Data type for curry lexer tokens
data Token = Token Category Attributes

instance Eq Token where
  Token c1 :: Category
c1 _ == :: Token -> Token -> Bool
== Token c2 :: Category
c2 _ = Category
c1 Category -> Category -> Bool
forall a. Eq a => a -> a -> Bool
== Category
c2

instance Ord Token where
  Token c1 :: Category
c1 _ compare :: Token -> Token -> Ordering
`compare` Token c2 :: Category
c2 _ = Category
c1 Category -> Category -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Category
c2

instance Symbol Token where
  isEOF :: Token -> Bool
isEOF (Token c :: Category
c _) = Category
c Category -> Category -> Bool
forall a. Eq a => a -> a -> Bool
== Category
EOF

  dist :: Int -> Token -> Distance
dist _ (Token VSemicolon         _) = (0,  0)
  dist _ (Token VRightBrace        _) = (0,  0)
  dist _ (Token EOF                _) = (0,  0)
  dist _ (Token DotDot             _) = (0,  1)
  dist _ (Token DoubleColon        _) = (0,  1)
  dist _ (Token LeftArrow          _) = (0,  1)
  dist _ (Token RightArrow         _) = (0,  1)
  dist _ (Token DoubleArrow        _) = (0,  1)
  dist _ (Token KW_do              _) = (0,  1)
  dist _ (Token KW_if              _) = (0,  1)
  dist _ (Token KW_in              _) = (0,  1)
  dist _ (Token KW_of              _) = (0,  1)
  dist _ (Token Id_as              _) = (0,  1)
  dist _ (Token KW_let             _) = (0,  2)
  dist _ (Token PragmaEnd          _) = (0,  2)
  dist _ (Token KW_case            _) = (0,  3)
  dist _ (Token KW_class           _) = (0,  4)
  dist _ (Token KW_data            _) = (0,  3)
  dist _ (Token KW_default         _) = (0,  6)
  dist _ (Token KW_deriving        _) = (0,  7)
  dist _ (Token KW_else            _) = (0,  3)
  dist _ (Token KW_free            _) = (0,  3)
  dist _ (Token KW_then            _) = (0,  3)
  dist _ (Token KW_type            _) = (0,  3)
  dist _ (Token KW_fcase           _) = (0,  4)
  dist _ (Token KW_infix           _) = (0,  4)
  dist _ (Token KW_instance        _) = (0,  7)
  dist _ (Token KW_where           _) = (0,  4)
  dist _ (Token Id_ccall           _) = (0,  4)
  dist _ (Token KW_import          _) = (0,  5)
  dist _ (Token KW_infixl          _) = (0,  5)
  dist _ (Token KW_infixr          _) = (0,  5)
  dist _ (Token KW_module          _) = (0,  5)
  dist _ (Token Id_forall          _) = (0,  5)
  dist _ (Token Id_hiding          _) = (0,  5)
  dist _ (Token KW_newtype         _) = (0,  6)
  dist _ (Token KW_external        _) = (0,  7)
  dist _ (Token Id_interface       _) = (0,  8)
  dist _ (Token Id_primitive       _) = (0,  8)
  dist _ (Token Id_qualified       _) = (0,  8)
  dist _ (Token PragmaHiding       _) = (0,  9)
  dist _ (Token PragmaLanguage     _) = (0, 11)
  dist _ (Token Id                 a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token QId                a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token Sym                a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token QSym               a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token IntTok             a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token FloatTok           a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist _ (Token CharTok            a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
  dist c :: Int
c (Token StringTok          a :: Attributes
a) = Int -> Distance -> Distance
updColDist Int
c (Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a)
  dist _ (Token LineComment        a :: Attributes
a) = Bool -> Attributes -> Distance
distAttr Bool
True  Attributes
a
  dist c :: Int
c (Token NestedComment      a :: Attributes
a) = Int -> Distance -> Distance
updColDist Int
c (Bool -> Attributes -> Distance
distAttr Bool
True  Attributes
a)
  dist _ (Token PragmaOptions      a :: Attributes
a) = let (ld :: Int
ld, cd :: Int
cd) = Bool -> Attributes -> Distance
distAttr Bool
False Attributes
a
                                        in  (Int
ld, Int
cd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 11)
  dist _ _                            = (0, 0)

-- TODO: Comment
updColDist :: Int -> Distance -> Distance
updColDist :: Int -> Distance -> Distance
updColDist c :: Int
c (ld :: Int
ld, cd :: Int
cd) = (Int
ld, if Int
ld Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Int
cd else Int
cd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)

distAttr :: Bool -> Attributes -> Distance
distAttr :: Bool -> Attributes -> Distance
distAttr isComment :: Bool
isComment attr :: Attributes
attr = case Attributes
attr of
  NoAttributes              -> (0, 0)
  CharAttributes     _ orig :: String
orig -> (0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
orig Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
  IntAttributes      _ orig :: String
orig -> (0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
orig Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
  FloatAttributes    _ orig :: String
orig -> (0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
orig Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
  StringAttributes   _ orig :: String
orig
      -- comment without surrounding quotes
    | Bool
isComment             -> (Int
ld, Int
cd)
      -- string with one ending double quote or two surrounding double quotes
      -- (column distance + 1 / + 2)
    | '\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
orig      -> (Int
ld, Int
cd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
    | Bool
otherwise             -> (Int
ld, Int
cd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
    where ld :: Int
ld = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter    (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') String
orig)
          cd :: Int
cd = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') (String -> String
forall a. [a] -> [a]
reverse String
orig)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
  IdentAttributes    mid :: [String]
mid i :: String
i  -> (0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String]
mid [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
i])) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
  OptionsAttributes mt :: Maybe String
mt args :: String
args -> case Maybe String
mt of
                                 Nothing -> (0, Int
distArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                                 Just t :: String
t  -> (0, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
distArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
    where distArgs :: Int
distArgs = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
args

-- |Category of curry tokens
data Category
  -- literals
  = CharTok
  | IntTok
  | FloatTok
  | StringTok

  -- identifiers
  | Id   -- identifier
  | QId  -- qualified identifier
  | Sym  -- symbol
  | QSym -- qualified symbol

  -- punctuation symbols
  | LeftParen     -- (
  | RightParen    -- )
  | Semicolon     -- ;
  | LeftBrace     -- {
  | RightBrace    -- }
  | LeftBracket   -- [
  | RightBracket  -- ]
  | Comma         -- ,
  | Underscore    -- _
  | Backquote     -- `

  -- layout
  | VSemicolon         -- virtual ;
  | VRightBrace        -- virtual }

  -- reserved keywords
  | KW_case
  | KW_class
  | KW_data
  | KW_default
  | KW_deriving
  | KW_do
  | KW_else
  | KW_external
  | KW_fcase
  | KW_free
  | KW_if
  | KW_import
  | KW_in
  | KW_infix
  | KW_infixl
  | KW_infixr
  | KW_instance
  | KW_let
  | KW_module
  | KW_newtype
  | KW_of
  | KW_then
  | KW_type
  | KW_where

  -- reserved operators
  | At           -- @
  | Colon        -- :
  | DotDot       -- ..
  | DoubleColon  -- ::
  | Equals       -- =
  | Backslash    -- \
  | Bar          -- |
  | LeftArrow    -- <-
  | RightArrow   -- ->
  | Tilde        -- ~
  | DoubleArrow  -- =>

  -- special identifiers
  | Id_as
  | Id_ccall
  | Id_forall
  | Id_hiding
  | Id_interface
  | Id_primitive
  | Id_qualified

  -- special operators
  | SymDot      -- .
  | SymMinus    -- -

  -- special symbols
  | SymStar -- kind star (*)

  -- pragmas
  | PragmaLanguage -- {-# LANGUAGE
  | PragmaOptions  -- {-# OPTIONS
  | PragmaHiding   -- {-# HIDING
  | PragmaMethod   -- {-# METHOD
  | PragmaModule   -- {-# MODULE
  | PragmaEnd      -- #-}


  -- comments (only for full lexer) inserted by men & bbr
  | LineComment
  | NestedComment

  -- end-of-file token
  | EOF
    deriving (Category -> Category -> Bool
(Category -> Category -> Bool)
-> (Category -> Category -> Bool) -> Eq Category
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Category -> Category -> Bool
$c/= :: Category -> Category -> Bool
== :: Category -> Category -> Bool
$c== :: Category -> Category -> Bool
Eq, Eq Category
Eq Category =>
(Category -> Category -> Ordering)
-> (Category -> Category -> Bool)
-> (Category -> Category -> Bool)
-> (Category -> Category -> Bool)
-> (Category -> Category -> Bool)
-> (Category -> Category -> Category)
-> (Category -> Category -> Category)
-> Ord Category
Category -> Category -> Bool
Category -> Category -> Ordering
Category -> Category -> Category
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Category -> Category -> Category
$cmin :: Category -> Category -> Category
max :: Category -> Category -> Category
$cmax :: Category -> Category -> Category
>= :: Category -> Category -> Bool
$c>= :: Category -> Category -> Bool
> :: Category -> Category -> Bool
$c> :: Category -> Category -> Bool
<= :: Category -> Category -> Bool
$c<= :: Category -> Category -> Bool
< :: Category -> Category -> Bool
$c< :: Category -> Category -> Bool
compare :: Category -> Category -> Ordering
$ccompare :: Category -> Category -> Ordering
$cp1Ord :: Eq Category
Ord)

-- There are different kinds of attributes associated with the tokens.
-- Most attributes simply save the string corresponding to the token.
-- However, for qualified identifiers, we also record the list of module
-- qualifiers. The values corresponding to a literal token are properly
-- converted already. To simplify the creation and extraction of
-- attribute values, we make use of records.

-- |Attributes associated to a token
data Attributes
  = NoAttributes
  | CharAttributes    { Attributes -> Char
cval     :: Char        , Attributes -> String
original :: String }
  | IntAttributes     { Attributes -> Integer
ival     :: Integer     , original :: String }
  | FloatAttributes   { Attributes -> Double
fval     :: Double      , original :: String }
  | StringAttributes  { Attributes -> String
sval     :: String      , original :: String }
  | IdentAttributes   { Attributes -> [String]
modulVal :: [String]    , sval     :: String }
  | OptionsAttributes { Attributes -> Maybe String
toolVal  :: Maybe String, Attributes -> String
toolArgs :: String }

instance Show Attributes where
  showsPrec :: Int -> Attributes -> String -> String
showsPrec _ NoAttributes             = Char -> String -> String
showChar '_'
  showsPrec _ (CharAttributes    cv :: Char
cv _) = Char -> String -> String
forall a. Show a => a -> String -> String
shows Char
cv
  showsPrec _ (IntAttributes     iv :: Integer
iv _) = Integer -> String -> String
forall a. Show a => a -> String -> String
shows Integer
iv
  showsPrec _ (FloatAttributes   fv :: Double
fv _) = Double -> String -> String
forall a. Show a => a -> String -> String
shows Double
fv
  showsPrec _ (StringAttributes  sv :: String
sv _) = String -> String -> String
forall a. Show a => a -> String -> String
shows String
sv
  showsPrec _ (IdentAttributes  mid :: [String]
mid i :: String
i) = String -> String -> String
showsEscaped
                                       (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
mid [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
i]
  showsPrec _ (OptionsAttributes mt :: Maybe String
mt s :: String
s) = Maybe String -> String -> String
showsTool Maybe String
mt
                                       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar ' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
s
    where showsTool :: Maybe String -> String -> String
showsTool = (String -> String)
-> (String -> String -> String) -> Maybe String -> String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String
forall a. a -> a
id (\t :: String
t -> Char -> String -> String
showChar '_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
t)


-- ---------------------------------------------------------------------------
-- The 'Show' instance of 'Token' is designed to display all tokens in their
-- source representation.
-- ---------------------------------------------------------------------------

showsEscaped :: String -> ShowS
showsEscaped :: String -> String -> String
showsEscaped s :: String
s = Char -> String -> String
showChar '`' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
s (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar '\''

showsIdent :: Attributes -> ShowS
showsIdent :: Attributes -> String -> String
showsIdent a :: Attributes
a = String -> String -> String
showString "identifier " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a

showsSpecialIdent :: String -> ShowS
showsSpecialIdent :: String -> String -> String
showsSpecialIdent s :: String
s = String -> String -> String
showString "identifier " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showsEscaped String
s

showsOperator :: Attributes -> ShowS
showsOperator :: Attributes -> String -> String
showsOperator a :: Attributes
a = String -> String -> String
showString "operator " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a

showsSpecialOperator :: String -> ShowS
showsSpecialOperator :: String -> String -> String
showsSpecialOperator s :: String
s = String -> String -> String
showString "operator " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showsEscaped String
s

instance Show Token where
  showsPrec :: Int -> Token -> String -> String
showsPrec _ (Token Id                 a :: Attributes
a) = Attributes -> String -> String
showsIdent Attributes
a
  showsPrec _ (Token QId                a :: Attributes
a) = String -> String -> String
showString "qualified "
                                           (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
showsIdent Attributes
a
  showsPrec _ (Token Sym                a :: Attributes
a) = Attributes -> String -> String
showsOperator Attributes
a
  showsPrec _ (Token QSym               a :: Attributes
a) = String -> String -> String
showString "qualified "
                                           (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
showsOperator Attributes
a
  showsPrec _ (Token IntTok             a :: Attributes
a) = String -> String -> String
showString "integer "   (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token FloatTok           a :: Attributes
a) = String -> String -> String
showString "float "     (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token CharTok            a :: Attributes
a) = String -> String -> String
showString "character " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token StringTok          a :: Attributes
a) = String -> String -> String
showString "string "    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token LeftParen          _) = String -> String -> String
showsEscaped "("
  showsPrec _ (Token RightParen         _) = String -> String -> String
showsEscaped ")"
  showsPrec _ (Token Semicolon          _) = String -> String -> String
showsEscaped ";"
  showsPrec _ (Token LeftBrace          _) = String -> String -> String
showsEscaped "{"
  showsPrec _ (Token RightBrace         _) = String -> String -> String
showsEscaped "}"
  showsPrec _ (Token LeftBracket        _) = String -> String -> String
showsEscaped "["
  showsPrec _ (Token RightBracket       _) = String -> String -> String
showsEscaped "]"
  showsPrec _ (Token Comma              _) = String -> String -> String
showsEscaped ","
  showsPrec _ (Token Underscore         _) = String -> String -> String
showsEscaped "_"
  showsPrec _ (Token Backquote          _) = String -> String -> String
showsEscaped "`"
  showsPrec _ (Token VSemicolon         _)
    = String -> String -> String
showsEscaped ";" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString " (inserted due to layout)"
  showsPrec _ (Token VRightBrace        _)
    = String -> String -> String
showsEscaped "}" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString " (inserted due to layout)"
  showsPrec _ (Token At                 _) = String -> String -> String
showsEscaped "@"
  showsPrec _ (Token Colon              _) = String -> String -> String
showsEscaped ":"
  showsPrec _ (Token DotDot             _) = String -> String -> String
showsEscaped ".."
  showsPrec _ (Token DoubleArrow        _) = String -> String -> String
showsEscaped "=>"
  showsPrec _ (Token DoubleColon        _) = String -> String -> String
showsEscaped "::"
  showsPrec _ (Token Equals             _) = String -> String -> String
showsEscaped "="
  showsPrec _ (Token Backslash          _) = String -> String -> String
showsEscaped "\\"
  showsPrec _ (Token Bar                _) = String -> String -> String
showsEscaped "|"
  showsPrec _ (Token LeftArrow          _) = String -> String -> String
showsEscaped "<-"
  showsPrec _ (Token RightArrow         _) = String -> String -> String
showsEscaped "->"
  showsPrec _ (Token Tilde              _) = String -> String -> String
showsEscaped "~"
  showsPrec _ (Token SymDot             _) = String -> String -> String
showsSpecialOperator "."
  showsPrec _ (Token SymMinus           _) = String -> String -> String
showsSpecialOperator "-"
  showsPrec _ (Token SymStar            _) = String -> String -> String
showsEscaped "*"
  showsPrec _ (Token KW_case            _) = String -> String -> String
showsEscaped "case"
  showsPrec _ (Token KW_class           _) = String -> String -> String
showsEscaped "class"
  showsPrec _ (Token KW_data            _) = String -> String -> String
showsEscaped "data"
  showsPrec _ (Token KW_default         _) = String -> String -> String
showsEscaped "default"
  showsPrec _ (Token KW_deriving        _) = String -> String -> String
showsEscaped "deriving"
  showsPrec _ (Token KW_do              _) = String -> String -> String
showsEscaped "do"
  showsPrec _ (Token KW_else            _) = String -> String -> String
showsEscaped "else"
  showsPrec _ (Token KW_external        _) = String -> String -> String
showsEscaped "external"
  showsPrec _ (Token KW_fcase           _) = String -> String -> String
showsEscaped "fcase"
  showsPrec _ (Token KW_free            _) = String -> String -> String
showsEscaped "free"
  showsPrec _ (Token KW_if              _) = String -> String -> String
showsEscaped "if"
  showsPrec _ (Token KW_import          _) = String -> String -> String
showsEscaped "import"
  showsPrec _ (Token KW_in              _) = String -> String -> String
showsEscaped "in"
  showsPrec _ (Token KW_infix           _) = String -> String -> String
showsEscaped "infix"
  showsPrec _ (Token KW_infixl          _) = String -> String -> String
showsEscaped "infixl"
  showsPrec _ (Token KW_infixr          _) = String -> String -> String
showsEscaped "infixr"
  showsPrec _ (Token KW_instance        _) = String -> String -> String
showsEscaped "instance"
  showsPrec _ (Token KW_let             _) = String -> String -> String
showsEscaped "let"
  showsPrec _ (Token KW_module          _) = String -> String -> String
showsEscaped "module"
  showsPrec _ (Token KW_newtype         _) = String -> String -> String
showsEscaped "newtype"
  showsPrec _ (Token KW_of              _) = String -> String -> String
showsEscaped "of"
  showsPrec _ (Token KW_then            _) = String -> String -> String
showsEscaped "then"
  showsPrec _ (Token KW_type            _) = String -> String -> String
showsEscaped "type"
  showsPrec _ (Token KW_where           _) = String -> String -> String
showsEscaped "where"
  showsPrec _ (Token Id_as              _) = String -> String -> String
showsSpecialIdent "as"
  showsPrec _ (Token Id_ccall           _) = String -> String -> String
showsSpecialIdent "ccall"
  showsPrec _ (Token Id_forall          _) = String -> String -> String
showsSpecialIdent "forall"
  showsPrec _ (Token Id_hiding          _) = String -> String -> String
showsSpecialIdent "hiding"
  showsPrec _ (Token Id_interface       _) = String -> String -> String
showsSpecialIdent "interface"
  showsPrec _ (Token Id_primitive       _) = String -> String -> String
showsSpecialIdent "primitive"
  showsPrec _ (Token Id_qualified       _) = String -> String -> String
showsSpecialIdent "qualified"
  showsPrec _ (Token PragmaLanguage     _) = String -> String -> String
showString "{-# LANGUAGE"
  showsPrec _ (Token PragmaOptions      a :: Attributes
a) = String -> String -> String
showString "{-# OPTIONS"
                                           (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token PragmaHiding       _) = String -> String -> String
showString "{-# HIDING"
  showsPrec _ (Token PragmaMethod       _) = String -> String -> String
showString "{-# METHOD"
  showsPrec _ (Token PragmaModule       _) = String -> String -> String
showString "{-# MODULE"
  showsPrec _ (Token PragmaEnd          _) = String -> String -> String
showString "#-}"
  showsPrec _ (Token LineComment        a :: Attributes
a) = Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token NestedComment      a :: Attributes
a) = Attributes -> String -> String
forall a. Show a => a -> String -> String
shows Attributes
a
  showsPrec _ (Token EOF                _) = String -> String -> String
showString "<end-of-file>"

-- ---------------------------------------------------------------------------
-- The following functions can be used to construct tokens with
-- specific attributes.
-- ---------------------------------------------------------------------------

-- |Construct a simple 'Token' without 'Attributes'
tok :: Category -> Token
tok :: Category -> Token
tok t :: Category
t = Category -> Attributes -> Token
Token Category
t Attributes
NoAttributes

-- |Construct a 'Token' for a single 'Char'
charTok :: Char -> String -> Token
charTok :: Char -> String -> Token
charTok c :: Char
c o :: String
o = Category -> Attributes -> Token
Token Category
CharTok CharAttributes :: Char -> String -> Attributes
CharAttributes { cval :: Char
cval = Char
c, original :: String
original = String
o }

-- |Construct a 'Token' for an int value
intTok :: Integer -> String -> Token
intTok :: Integer -> String -> Token
intTok base :: Integer
base digits :: String
digits = Category -> Attributes -> Token
Token Category
IntTok IntAttributes :: Integer -> String -> Attributes
IntAttributes
  { ival :: Integer
ival = Integer -> String -> Integer
forall a. Num a => a -> String -> a
convertIntegral Integer
base String
digits, original :: String
original = String
digits }

-- |Construct a 'Token' for a float value
floatTok :: String -> String -> Int -> String -> Token
floatTok :: String -> String -> Int -> String -> Token
floatTok mant :: String
mant frac :: String
frac expo :: Int
expo rest :: String
rest = Category -> Attributes -> Token
Token Category
FloatTok FloatAttributes :: Double -> String -> Attributes
FloatAttributes
  { fval :: Double
fval     = String -> String -> Int -> Double
forall a. Fractional a => String -> String -> Int -> a
convertFloating String
mant String
frac Int
expo
  , original :: String
original = String
mant String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
frac String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest }

-- |Construct a 'Token' for a string value
stringTok :: String -> String -> Token
stringTok :: String -> String -> Token
stringTok cs :: String
cs s :: String
s = Category -> Attributes -> Token
Token Category
StringTok StringAttributes :: String -> String -> Attributes
StringAttributes { sval :: String
sval = String
cs, original :: String
original = String
s }

-- |Construct a 'Token' for identifiers
idTok :: Category -> [String] -> String -> Token
idTok :: Category -> [String] -> String -> Token
idTok t :: Category
t mIdent :: [String]
mIdent ident :: String
ident = Category -> Attributes -> Token
Token Category
t
  IdentAttributes :: [String] -> String -> Attributes
IdentAttributes { modulVal :: [String]
modulVal = [String]
mIdent, sval :: String
sval = String
ident }

-- TODO
pragmaOptionsTok :: Maybe String -> String -> Token
pragmaOptionsTok :: Maybe String -> String -> Token
pragmaOptionsTok mbTool :: Maybe String
mbTool s :: String
s = Category -> Attributes -> Token
Token Category
PragmaOptions
  OptionsAttributes :: Maybe String -> String -> Attributes
OptionsAttributes { toolVal :: Maybe String
toolVal = Maybe String
mbTool, toolArgs :: String
toolArgs = String
s }

-- |Construct a 'Token' for a line comment
lineCommentTok :: String -> Token
lineCommentTok :: String -> Token
lineCommentTok s :: String
s = Category -> Attributes -> Token
Token Category
LineComment
  StringAttributes :: String -> String -> Attributes
StringAttributes { sval :: String
sval = String
s, original :: String
original = String
s }

-- |Construct a 'Token' for a nested comment
nestedCommentTok :: String -> Token
nestedCommentTok :: String -> Token
nestedCommentTok s :: String
s = Category -> Attributes -> Token
Token Category
NestedComment
  StringAttributes :: String -> String -> Attributes
StringAttributes { sval :: String
sval = String
s, original :: String
original = String
s }

-- ---------------------------------------------------------------------------
-- Tables for reserved operators and identifiers
-- ---------------------------------------------------------------------------

-- |Map of reserved operators
reservedOps:: Map.Map String Category
reservedOps :: Map String Category
reservedOps = [(String, Category)] -> Map String Category
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ("@" , Category
At         )
  , (":" , Category
Colon      )
  , ("=>", Category
DoubleArrow)
  , ("::", Category
DoubleColon)
  , ("..", Category
DotDot     )
  , ("=" , Category
Equals     )
  , ("\\", Category
Backslash  )
  , ("|" , Category
Bar        )
  , ("<-", Category
LeftArrow  )
  , ("->", Category
RightArrow )
  , ("~" , Category
Tilde      )
  ]

-- |Map of reserved and special operators
reservedSpecialOps :: Map.Map String Category
reservedSpecialOps :: Map String Category
reservedSpecialOps = Map String Category -> Map String Category -> Map String Category
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String Category
reservedOps (Map String Category -> Map String Category)
-> Map String Category -> Map String Category
forall a b. (a -> b) -> a -> b
$ [(String, Category)] -> Map String Category
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ("." , Category
SymDot     )
  , ("-" , Category
SymMinus   )
  , ("*" , Category
SymStar    )
  ]

-- |Map of keywords
keywords :: Map.Map String Category
keywords :: Map String Category
keywords = [(String, Category)] -> Map String Category
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ("case"    , Category
KW_case    )
  , ("class"   , Category
KW_class   )
  , ("data"    , Category
KW_data    )
  , ("default" , Category
KW_default )
  , ("deriving", Category
KW_deriving)
  , ("do"      , Category
KW_do      )
  , ("else"    , Category
KW_else    )
  , ("external", Category
KW_external)
  , ("fcase"   , Category
KW_fcase   )
  , ("free"    , Category
KW_free    )
  , ("if"      , Category
KW_if      )
  , ("import"  , Category
KW_import  )
  , ("in"      , Category
KW_in      )
  , ("infix"   , Category
KW_infix   )
  , ("infixl"  , Category
KW_infixl  )
  , ("infixr"  , Category
KW_infixr  )
  , ("instance", Category
KW_instance)
  , ("let"     , Category
KW_let     )
  , ("module"  , Category
KW_module  )
  , ("newtype" , Category
KW_newtype )
  , ("of"      , Category
KW_of      )
  , ("then"    , Category
KW_then    )
  , ("type"    , Category
KW_type    )
  , ("where"   , Category
KW_where   )
  ]

-- |Map of keywords and special identifiers
keywordsSpecialIds :: Map.Map String Category
keywordsSpecialIds :: Map String Category
keywordsSpecialIds = Map String Category -> Map String Category -> Map String Category
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String Category
keywords (Map String Category -> Map String Category)
-> Map String Category -> Map String Category
forall a b. (a -> b) -> a -> b
$ [(String, Category)] -> Map String Category
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ("as"       , Category
Id_as       )
  , ("ccall"    , Category
Id_ccall    )
  , ("forall"   , Category
Id_forall   )
  , ("hiding"   , Category
Id_hiding   )
  , ("interface", Category
Id_interface)
  , ("primitive", Category
Id_primitive)
  , ("qualified", Category
Id_qualified)
  ]

pragmas :: Map.Map String Category
pragmas :: Map String Category
pragmas = [(String, Category)] -> Map String Category
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ ("language", Category
PragmaLanguage)
  , ("options" , Category
PragmaOptions )
  , ("hiding"  , Category
PragmaHiding  )
  , ("method"  , Category
PragmaMethod  )
  , ("module"  , Category
PragmaModule  )
  ]


-- ---------------------------------------------------------------------------
-- Character classes
-- ---------------------------------------------------------------------------

-- |Check whether a 'Char' is allowed for identifiers
isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "'_"

-- |Check whether a 'Char' is allowed for symbols
isSymbolChar :: Char -> Bool
isSymbolChar :: Char -> Bool
isSymbolChar c :: Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "~!@#$%^&*+-=<>:?./|\\"

-- ---------------------------------------------------------------------------
-- Lexing functions
-- ---------------------------------------------------------------------------

-- |Lex source code
lexSource :: FilePath -> String -> CYM [(Span, Token)]
lexSource :: String -> String -> CYM [(Span, Token)]
lexSource = P [(Span, Token)] -> String -> String -> CYM [(Span, Token)]
forall a. P a -> String -> String -> CYM a
parse (Lexer Token [(Span, Token)] -> P [(Span, Token)]
forall s. Symbol s => Lexer s [(Span, s)] -> P [(Span, s)]
applyLexer Lexer Token [(Span, Token)]
forall a. Lexer Token a
fullLexer)

-- |CPS-Lexer for Curry
lexer :: Lexer Token a
lexer :: Lexer Token a
lexer = Bool -> Lexer Token a
forall a. Bool -> Lexer Token a
skipWhiteSpace Bool
True -- skip comments

-- |CPS-Lexer for Curry which also lexes comments.
-- This lexer is useful for documentation tools.
fullLexer :: Lexer Token a
fullLexer :: Lexer Token a
fullLexer = Bool -> Lexer Token a
forall a. Bool -> Lexer Token a
skipWhiteSpace Bool
False -- lex comments

-- |Lex the source code and skip whitespaces
skipWhiteSpace :: Bool -> Lexer Token a
skipWhiteSpace :: Bool -> Lexer Token a
skipWhiteSpace skipComments :: Bool
skipComments suc :: SuccessP Token a
suc fail :: FailP a
fail = P a
skip
  where
  skip :: P a
skip sp :: Span
sp   []              bol :: Bool
bol = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
EOF)                   Span
sp            [] Bool
bol
  skip sp :: Span
sp c :: String
c@('-':'-':_)     _   = Lexer Token a
forall a. Lexer Token a
lexLineComment     SuccessP Token a
sucComment FailP a
fail Span
sp            String
c  Bool
True
  skip sp :: Span
sp c :: String
c@('{':'-':'#':_) bol :: Bool
bol = P a -> Lexer Token a
forall a. P a -> Lexer Token a
lexPragma P a
noPragma SuccessP Token a
suc        FailP a
fail Span
sp            String
c  Bool
bol
  skip sp :: Span
sp c :: String
c@('{':'-':_)     bol :: Bool
bol = Lexer Token a
forall a. Lexer Token a
lexNestedComment   SuccessP Token a
sucComment FailP a
fail Span
sp            String
c  Bool
bol
  skip sp :: Span
sp cs :: String
cs@(c :: Char
c:s :: String
s)          bol :: Bool
bol
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t'                = Span -> String -> P a -> P a
forall a. Span -> String -> P a -> P a
warnP Span
sp "Tab character" P a
skip       (Span -> Span
tabSpan  Span
sp) String
s  Bool
bol
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'                = P a
skip                                (Span -> Span
nlSpan   Span
sp) String
s  Bool
True
    | Char -> Bool
isSpace Char
c                = P a
skip                                (Span -> Span
nextSpan Span
sp) String
s  Bool
bol
    | Bool
bol                      = Lexer Token a
forall a. Lexer Token a
lexBOL             SuccessP Token a
suc        FailP a
fail  Span
sp            String
cs Bool
bol
    | Bool
otherwise                = Lexer Token a
forall a. Lexer Token a
lexToken           SuccessP Token a
suc        FailP a
fail  Span
sp            String
cs Bool
bol
  sucComment :: SuccessP Token a
sucComment = if Bool
skipComments then (\ _suc :: Span
_suc _fail :: Token
_fail -> P a
skip) else SuccessP Token a
suc
  noPragma :: P a
noPragma   = Lexer Token a
forall a. Lexer Token a
lexNestedComment SuccessP Token a
sucComment FailP a
fail

-- Lex a line comment
lexLineComment :: Lexer Token a
lexLineComment :: Lexer Token a
lexLineComment suc :: SuccessP Token a
suc _ sp :: Span
sp str :: String
str = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') String
str of
  (c :: String
c, s :: String
s ) -> SuccessP Token a
suc Span
sp (String -> Token
lineCommentTok String
c) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c) String
s

lexPragma :: P a -> Lexer Token a
lexPragma :: P a -> Lexer Token a
lexPragma noPragma :: P a
noPragma suc :: SuccessP Token a
suc fail :: FailP a
fail sp0 :: Span
sp0 str :: String
str = P a
pragma (Span -> Int -> Span
incrSpan Span
sp0 3) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 3 String
str)
  where
  skip :: Bool -> Context -> CYM a
skip = P a
noPragma Span
sp0 String
str
  pragma :: P a
pragma sp :: Span
sp []         = FailP a
fail Span
sp0 "Unterminated pragma" Span
sp []
  pragma sp :: Span
sp cs :: String
cs@(c :: Char
c : s :: String
s)
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t' = P a
pragma (Span -> Span
tabSpan  Span
sp) String
s
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = P a
pragma (Span -> Span
nlSpan   Span
sp) String
s
    | Char -> Bool
isSpace Char
c = P a
pragma (Span -> Span
nextSpan Span
sp) String
s
    | Char -> Bool
isAlpha Char
c = case String -> Map String Category -> Maybe Category
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
prag) Map String Category
pragmas of
        Nothing            -> Bool -> Context -> CYM a
skip
        Just PragmaOptions -> Span -> Lexer Token a
forall a. Span -> Lexer Token a
lexOptionsPragma Span
sp0 SuccessP Token a
suc FailP a
fail Span
sp1 String
rest
        Just t :: Category
t             -> SuccessP Token a
suc Span
sp0 (Category -> Token
tok Category
t)               Span
sp1 String
rest
    | Bool
otherwise = Bool -> Context -> CYM a
skip
    where
    (prag :: String
prag, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum String
cs
    sp1 :: Span
sp1          = Span -> Int -> Span
incrSpan Span
sp (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prag)

lexOptionsPragma :: Span -> Lexer Token a
lexOptionsPragma :: Span -> Lexer Token a
lexOptionsPragma sp0 :: Span
sp0 _   fail :: FailP a
fail sp :: Span
sp [] = FailP a
fail Span
sp0 "Unterminated Options pragma" Span
sp []
lexOptionsPragma sp0 :: Span
sp0 suc :: SuccessP Token a
suc fail :: FailP a
fail sp :: Span
sp (c :: Char
c : s :: String
s)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t' = Maybe String -> Span -> String -> Bool -> Context -> CYM a
lexArgs Maybe String
forall a. Maybe a
Nothing (Span -> Span
tabSpan  Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = Maybe String -> Span -> String -> Bool -> Context -> CYM a
lexArgs Maybe String
forall a. Maybe a
Nothing (Span -> Span
nlSpan   Span
sp) String
s
  | Char -> Bool
isSpace Char
c = Maybe String -> Span -> String -> Bool -> Context -> CYM a
lexArgs Maybe String
forall a. Maybe a
Nothing (Span -> Span
nextSpan Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'  = let (tool :: String
tool, s1 :: String
s1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isIdentChar String
s
                in  Maybe String -> Span -> String -> Bool -> Context -> CYM a
lexArgs (String -> Maybe String
forall a. a -> Maybe a
Just String
tool) (Span -> Int -> Span
incrSpan Span
sp (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
tool Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) String
s1
  | Bool
otherwise = FailP a
fail Span
sp0 "Malformed Options pragma" Span
sp String
s
  where
  lexArgs :: Maybe String -> Span -> String -> Bool -> Context -> CYM a
lexArgs mbTool :: Maybe String
mbTool = String -> Span -> String -> Bool -> Context -> CYM a
lexRaw ""
    where
    lexRaw :: String -> Span -> String -> Bool -> Context -> CYM a
lexRaw s0 :: String
s0 sp1 :: Span
sp1 r :: String
r = case String
hash of
      []            -> FailP a
fail Span
sp0 "End-of-file inside pragma" (Span -> Int -> Span
incrSpan Span
sp1 Int
len) []
      '#':'-':'}':_ -> String -> Span -> String -> Bool -> Context -> CYM a
token  (String -> String
trim (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
s0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opts) (Span -> Int -> Span
incrSpan Span
sp1 Int
len)       String
hash
      _             -> String -> Span -> String -> Bool -> Context -> CYM a
lexRaw (String
s0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ "#") (Span -> Int -> Span
incrSpan Span
sp1 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 String
hash)
      where
      (opts :: String
opts, hash :: String
hash) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '#') String
r
      len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
opts
      token :: String -> Span -> String -> Bool -> Context -> CYM a
token = SuccessP Token a
suc Span
sp0 (Token -> Span -> String -> Bool -> Context -> CYM a)
-> (String -> Token)
-> String
-> Span
-> String
-> Bool
-> Context
-> CYM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String -> Token
pragmaOptionsTok Maybe String
mbTool
      trim :: String -> String
trim = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- Lex a nested comment
lexNestedComment :: Lexer Token a
lexNestedComment :: Lexer Token a
lexNestedComment suc :: SuccessP Token a
suc fail :: FailP a
fail sp0 :: Span
sp0 = Integer
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
forall a.
(Eq a, Num a) =>
a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
lnc (0 :: Integer) String -> String
forall a. a -> a
id Span
sp0
  where
  -- d   : nesting depth
  -- comm: comment already lexed as functional list
  lnc :: a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
lnc d :: a
d comm :: String -> String
comm sp :: Span
sp str :: String
str = case (a
d, String
str) of
    (_,        []) -> FailP a
fail Span
sp0    "Unterminated nested comment"  Span
sp          []
    (1, '-':'}':s :: String
s) -> SuccessP Token a
suc  Span
sp0    (String -> Token
nestedCommentTok (String -> String
comm "-}")) (Span -> Int -> Span
incrSpan Span
sp 2) String
s
    (_, '{':'-':s :: String
s) -> a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont (a
da -> a -> a
forall a. Num a => a -> a -> a
+1) ("{-" String -> String -> String
forall a. [a] -> [a] -> [a]
++)                       (Span -> Int -> Span
incrSpan Span
sp 2) String
s
    (_, '-':'}':s :: String
s) -> a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont (a
da -> a -> a
forall a. Num a => a -> a -> a
-1) ("-}" String -> String -> String
forall a. [a] -> [a] -> [a]
++)                       (Span -> Int -> Span
incrSpan Span
sp 2) String
s
    (_, c :: Char
c@Char
'\t' :s :: String
s) -> a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont a
d     (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)                            (Span -> Span
tabSpan    Span
sp) String
s
    (_, c :: Char
c@Char
'\n' :s :: String
s) -> a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont a
d     (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)                            (Span -> Span
nlSpan     Span
sp) String
s
    (_, c :: Char
c      :s :: String
s) -> a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont a
d     (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)                            (Span -> Span
nextSpan   Span
sp) String
s
    where cont :: a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
cont d' :: a
d' comm' :: String -> String
comm' = a
-> (String -> String) -> Span -> String -> Bool -> Context -> CYM a
lnc a
d' (String -> String
comm (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
comm')

-- Lex tokens at the beginning of a line, managing layout.
lexBOL :: Lexer Token a
lexBOL :: Lexer Token a
lexBOL suc :: SuccessP Token a
suc fail :: FailP a
fail sp :: Span
sp s :: String
s _ []            = Lexer Token a
forall a. Lexer Token a
lexToken SuccessP Token a
suc FailP a
fail Span
sp String
s Bool
False []
lexBOL suc :: SuccessP Token a
suc fail :: FailP a
fail sp :: Span
sp s :: String
s _ ctxt :: Context
ctxt@(n :: Int
n:rest :: Context
rest)
  | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
n  = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
VRightBrace) Span
sp String
s Bool
True  Context
rest
  | Int
col Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n  = Lexer Token a
forall a. Lexer Token a
lexSemiOrWhere SuccessP Token a
suc FailP a
fail  Span
sp String
s Bool
False Context
ctxt
  | Bool
otherwise = Lexer Token a
forall a. Lexer Token a
lexToken       SuccessP Token a
suc FailP a
fail  Span
sp String
s Bool
False Context
ctxt
  where col :: Int
col = Position -> Int
column (Span -> Position
span2Pos Span
sp)

lexSemiOrWhere :: Lexer Token a
lexSemiOrWhere :: Lexer Token a
lexSemiOrWhere suc :: SuccessP Token a
suc _ sp :: Span
sp ('w':'h':'e':'r':'e':s :: String
s@(c :: Char
c:_))
  | Bool -> Bool
not (Char -> Bool
isIdentChar Char
c)   = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
KW_where)   Span
sp String
s
lexSemiOrWhere suc :: SuccessP Token a
suc _ sp :: Span
sp s :: String
s = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
VSemicolon) Span
sp String
s

-- Lex a single 'Token'
lexToken :: Lexer Token a
lexToken :: Lexer Token a
lexToken suc :: SuccessP Token a
suc _    sp :: Span
sp []       = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
EOF) Span
sp []
lexToken suc :: SuccessP Token a
suc fail :: FailP a
fail sp :: Span
sp cs :: String
cs@(c :: Char
c:s :: String
s)
  | Int -> String -> String
forall a. Int -> [a] -> [a]
take 3 String
cs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "#-}" = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
PragmaEnd) (Span -> Int -> Span
incrSpan Span
sp 3) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 3 String
cs)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '('           = Category -> Bool -> Context -> CYM a
token Category
LeftParen
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')'           = Category -> Bool -> Context -> CYM a
token Category
RightParen
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ','           = Category -> Bool -> Context -> CYM a
token Category
Comma
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';'           = Category -> Bool -> Context -> CYM a
token Category
Semicolon
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '['           = Category -> Bool -> Context -> CYM a
token Category
LeftBracket
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ']'           = Category -> Bool -> Context -> CYM a
token Category
RightBracket
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'           = Category -> Bool -> Context -> CYM a
token Category
Underscore
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '`'           = Category -> Bool -> Context -> CYM a
token Category
Backquote
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '{'           = Category -> Bool -> Context -> CYM a
token Category
LeftBrace
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '}'           = (Token -> P a) -> P a
forall a. (Token -> P a) -> P a
lexRightBrace (SuccessP Token a
suc Span
sp) (Span -> Span
nextSpan Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''          = Span -> Lexer Token a
forall a. Span -> Lexer Token a
lexChar   Span
sp SuccessP Token a
suc FailP a
fail  (Span -> Span
nextSpan Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\"'          = Span -> Lexer Token a
forall a. Span -> Lexer Token a
lexString Span
sp SuccessP Token a
suc FailP a
fail  (Span -> Span
nextSpan Span
sp) String
s
  | Char -> Bool
isAlpha      Char
c     = (Token -> P a) -> P a
forall a. (Token -> P a) -> P a
lexIdent      (SuccessP Token a
suc Span
sp) Span
sp            String
cs
  | Char -> Bool
isSymbolChar Char
c     = (Token -> P a) -> P a
forall a. (Token -> P a) -> P a
lexSymbol     (SuccessP Token a
suc Span
sp) Span
sp            String
cs
  | Char -> Bool
isDigit      Char
c     = (Token -> P a) -> P a
forall a. (Token -> P a) -> P a
lexNumber     (SuccessP Token a
suc Span
sp) Span
sp            String
cs
  | Bool
otherwise          = FailP a
fail Span
sp ("Illegal character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c) Span
sp String
s
  where token :: Category -> Bool -> Context -> CYM a
token t :: Category
t = SuccessP Token a
suc Span
sp (Category -> Token
tok Category
t) (Span -> Span
nextSpan Span
sp) String
s

-- Lex a right brace and pop from the context stack
lexRightBrace :: (Token -> P a) -> P a
lexRightBrace :: (Token -> P a) -> P a
lexRightBrace cont :: Token -> P a
cont sp :: Span
sp s :: String
s bol :: Bool
bol ctxt :: Context
ctxt = Token -> P a
cont (Category -> Token
tok Category
RightBrace) Span
sp String
s Bool
bol (Int -> Context -> Context
forall a. Int -> [a] -> [a]
drop 1 Context
ctxt)

-- Lex an identifier
lexIdent :: (Token -> P a) -> P a
lexIdent :: (Token -> P a) -> P a
lexIdent cont :: Token -> P a
cont sp :: Span
sp s :: String
s = P a -> (Category -> P a) -> Maybe Category -> P a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Token -> P a) -> Token -> [String] -> P a
forall a. (Token -> P a) -> Token -> [String] -> P a
lexOptQual Token -> P a
cont (Category -> Token
token Category
Id) [String
ident]) (Token -> P a
cont (Token -> P a) -> (Category -> Token) -> Category -> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Token
token)
                          (String -> Map String Category -> Maybe Category
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ident Map String Category
keywordsSpecialIds)
                          (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ident) String
rest
  where (ident :: String
ident, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isIdentChar String
s
        token :: Category -> Token
token t :: Category
t       = Category -> [String] -> String -> Token
idTok Category
t [] String
ident

-- Lex a symbol
lexSymbol :: (Token -> P a) -> P a
lexSymbol :: (Token -> P a) -> P a
lexSymbol cont :: Token -> P a
cont sp :: Span
sp s :: String
s = Token -> P a
cont
  (Category -> [String] -> String -> Token
idTok (Category -> String -> Map String Category -> Category
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Category
Sym String
sym Map String Category
reservedSpecialOps) [] String
sym)
  (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sym) String
rest
  where (sym :: String
sym, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSymbolChar String
s

-- Lex an optionally qualified entity (identifier or symbol).
lexOptQual :: (Token -> P a) -> Token -> [String] -> P a
lexOptQual :: (Token -> P a) -> Token -> [String] -> P a
lexOptQual cont :: Token -> P a
cont token :: Token
token mIdent :: [String]
mIdent sp :: Span
sp cs :: String
cs@('.':c :: Char
c:s :: String
s)
  | Char -> Bool
isAlpha  Char
c                 = (Token -> P a) -> P a -> [String] -> P a
forall a. (Token -> P a) -> P a -> [String] -> P a
lexQualIdent Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
identCont [String]
mIdent
                                   (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  | Char -> Bool
isSymbolChar Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.' = (Token -> P a) -> P a -> [String] -> P a
forall a. (Token -> P a) -> P a -> [String] -> P a
lexQualSymbol Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
identCont [String]
mIdent
                                   (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
--   | c `elem` ":[("   = lexQualPrimitive cont token     mIdent (nextSpan sp) (c:s)
  where identCont :: p -> p -> Bool -> Context -> CYM a
identCont _ _ = Token -> P a
cont Token
token Span
sp String
cs
lexOptQual cont :: Token -> P a
cont token :: Token
token mIdent :: [String]
mIdent sp :: Span
sp cs :: String
cs@('.':'.':c :: Char
c:s :: String
s)
  |       Char -> Bool
isSymbolChar Char
c =       (Token -> P a) -> P a -> [String] -> P a
forall a. (Token -> P a) -> P a -> [String] -> P a
lexQualSymbol Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
identCont [String]
mIdent
                                   (Span -> Span
nextSpan Span
sp) ('.'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isIdentChar  Char
c =       (Token -> P a) -> P a -> [String] -> P a
forall a. (Token -> P a) -> P a -> [String] -> P a
lexQualSymbol Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
identCont [String]
mIdent
                                   (Span -> Span
nextSpan Span
sp) ('.'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  where identCont :: p -> p -> Bool -> Context -> CYM a
identCont _ _ = Token -> P a
cont Token
token Span
sp String
cs
lexOptQual cont :: Token -> P a
cont token :: Token
token _      sp :: Span
sp cs :: String
cs = Token -> P a
cont Token
token Span
sp String
cs

-- Lex a qualified identifier.
lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a
lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a
lexQualIdent cont :: Token -> P a
cont identCont :: P a
identCont mIdent :: [String]
mIdent sp :: Span
sp s :: String
s =
  P a -> (Category -> P a) -> Maybe Category -> P a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Token -> P a) -> Token -> [String] -> P a
forall a. (Token -> P a) -> Token -> [String] -> P a
lexOptQual Token -> P a
cont (Category -> [String] -> String -> Token
idTok Category
QId [String]
mIdent String
ident) ([String]
mIdent [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
ident]))
        (P a -> Category -> P a
forall a b. a -> b -> a
const P a
identCont)
        (String -> Map String Category -> Maybe Category
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ident Map String Category
keywords)
        (Span -> Int -> Span
incrSpan Span
sp (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ident)) String
rest
  where (ident :: String
ident, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isIdentChar String
s

-- Lex a qualified symbol.
lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a
lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a
lexQualSymbol cont :: Token -> P a
cont identCont :: P a
identCont mIdent :: [String]
mIdent sp :: Span
sp s :: String
s =
  P a -> (Category -> P a) -> Maybe Category -> P a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Token -> P a
cont (Category -> [String] -> String -> Token
idTok Category
QSym [String]
mIdent String
sym)) (P a -> Category -> P a
forall a b. a -> b -> a
const P a
identCont)
        (String -> Map String Category -> Maybe Category
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sym Map String Category
reservedOps)
        (Span -> Int -> Span
incrSpan Span
sp (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sym)) String
rest
  where (sym :: String
sym, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSymbolChar String
s

-- ---------------------------------------------------------------------------
-- /Note:/ since Curry allows an unlimited range of integer numbers,
-- read numbers must be converted to Haskell type 'Integer'.
-- ---------------------------------------------------------------------------

-- Lex a numeric literal.
lexNumber :: (Token -> P a) -> P a
lexNumber :: (Token -> P a) -> P a
lexNumber cont :: Token -> P a
cont sp :: Span
sp ('0':c :: Char
c:s :: String
s)
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "bB"  = (Token -> P a) -> P a -> P a
forall a. (Token -> P a) -> P a -> P a
lexBinary      Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
nullCont (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "oO"  = (Token -> P a) -> P a -> P a
forall a. (Token -> P a) -> P a -> P a
lexOctal       Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
nullCont (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "xX"  = (Token -> P a) -> P a -> P a
forall a. (Token -> P a) -> P a -> P a
lexHexadecimal Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
nullCont (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  where nullCont :: p -> p -> Bool -> Context -> CYM a
nullCont _ _ = Token -> P a
cont (Integer -> String -> Token
intTok 10 "0") (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
lexNumber cont :: Token -> P a
cont sp :: Span
sp s :: String
s = (Token -> P a) -> Token -> String -> P a
forall a. (Token -> P a) -> Token -> String -> P a
lexOptFraction Token -> P a
cont (Integer -> String -> Token
intTok 10 String
digits) String
digits
                     (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s

-- Lex a binary literal.
lexBinary :: (Token -> P a) -> P a -> P a
lexBinary :: (Token -> P a) -> P a -> P a
lexBinary cont :: Token -> P a
cont nullCont :: P a
nullCont sp :: Span
sp s :: String
s
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
digits = P a
nullCont Span
forall a. HasCallStack => a
undefined String
forall a. HasCallStack => a
undefined
  | Bool
otherwise   = Token -> P a
cont (Integer -> String -> Token
intTok 2 String
digits) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isBinDigit String
s
        isBinDigit :: Char -> Bool
isBinDigit c :: Char
c   = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '1'

-- Lex an octal literal.
lexOctal :: (Token -> P a) -> P a -> P a
lexOctal :: (Token -> P a) -> P a -> P a
lexOctal cont :: Token -> P a
cont nullCont :: P a
nullCont sp :: Span
sp s :: String
s
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
digits = P a
nullCont Span
forall a. HasCallStack => a
undefined String
forall a. HasCallStack => a
undefined
  | Bool
otherwise   = Token -> P a
cont (Integer -> String -> Token
intTok 8 String
digits) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isOctDigit String
s

-- Lex a hexadecimal literal.
lexHexadecimal :: (Token -> P a) -> P a -> P a
lexHexadecimal :: (Token -> P a) -> P a -> P a
lexHexadecimal cont :: Token -> P a
cont nullCont :: P a
nullCont sp :: Span
sp s :: String
s
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
digits = P a
nullCont Span
forall a. HasCallStack => a
undefined String
forall a. HasCallStack => a
undefined
  | Bool
otherwise   = Token -> P a
cont (Integer -> String -> Token
intTok 16 String
digits) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
s

-- Lex an optional fractional part (float literal).
lexOptFraction :: (Token -> P a) -> Token -> String -> P a
lexOptFraction :: (Token -> P a) -> Token -> String -> P a
lexOptFraction cont :: Token -> P a
cont _ mant :: String
mant sp :: Span
sp ('.':c :: Char
c:s :: String
s)
  | Char -> Bool
isDigit Char
c = (Token -> P a) -> Token -> String -> String -> P a
forall a. (Token -> P a) -> Token -> String -> String -> P a
lexOptExponent Token -> P a
cont (String -> String -> Int -> String -> Token
floatTok String
mant String
frac 0 "") String
mant String
frac
                               (Span -> Int -> Span
incrSpan Span
sp (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fracInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) String
rest
  where (frac :: String
frac,rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
lexOptFraction cont :: Token -> P a
cont token :: Token
token mant :: String
mant sp :: Span
sp (c :: Char
c:s :: String
s)
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "eE" = (Token -> P a) -> P a -> String -> String -> String -> P a
forall a.
(Token -> P a) -> P a -> String -> String -> String -> P a
lexSignedExponent Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
intCont String
mant "" [Char
c] (Span -> Span
nextSpan Span
sp) String
s
  where intCont :: p -> p -> Bool -> Context -> CYM a
intCont _ _ = Token -> P a
cont Token
token Span
sp (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
lexOptFraction cont :: Token -> P a
cont token :: Token
token _ sp :: Span
sp s :: String
s = Token -> P a
cont Token
token Span
sp String
s

-- Lex an optional exponent (float literal).
lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a
lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a
lexOptExponent cont :: Token -> P a
cont token :: Token
token mant :: String
mant frac :: String
frac sp :: Span
sp (c :: Char
c:s :: String
s)
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "eE" = (Token -> P a) -> P a -> String -> String -> String -> P a
forall a.
(Token -> P a) -> P a -> String -> String -> String -> P a
lexSignedExponent Token -> P a
cont P a
forall p p. p -> p -> Bool -> Context -> CYM a
floatCont String
mant String
frac [Char
c] (Span -> Span
nextSpan Span
sp) String
s
  where floatCont :: p -> p -> Bool -> Context -> CYM a
floatCont _ _ = Token -> P a
cont Token
token Span
sp (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
lexOptExponent cont :: Token -> P a
cont token :: Token
token _    _    sp :: Span
sp s :: String
s = Token -> P a
cont Token
token Span
sp String
s

-- Lex an exponent with sign (float literal).
lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String
                  -> P a
lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String -> P a
lexSignedExponent cont :: Token -> P a
cont floatCont :: P a
floatCont mant :: String
mant frac :: String
frac e :: String
e sp :: Span
sp str :: String
str = case String
str of
  ('+':c :: Char
c:s :: String
s) | Char -> Bool
isDigit Char
c -> String -> (Int -> Int) -> P a
lexExpo (String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ "+") Int -> Int
forall a. a -> a
id     (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  ('-':c :: Char
c:s :: String
s) | Char -> Bool
isDigit Char
c -> String -> (Int -> Int) -> P a
lexExpo (String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-") Int -> Int
forall a. Num a => a -> a
negate (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  (c :: Char
c:_)     | Char -> Bool
isDigit Char
c -> String -> (Int -> Int) -> P a
lexExpo String
e          Int -> Int
forall a. a -> a
id     Span
sp            String
str
  _                     -> P a
floatCont                 Span
sp            String
str
  where lexExpo :: String -> (Int -> Int) -> P a
lexExpo = (Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a
forall a.
(Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a
lexExponent Token -> P a
cont String
mant String
frac

-- Lex an exponent without sign (float literal).
lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int)
            -> P a
lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a
lexExponent cont :: Token -> P a
cont mant :: String
mant frac :: String
frac e :: String
e expSign :: Int -> Int
expSign sp :: Span
sp s :: String
s =
  Token -> P a
cont (String -> String -> Int -> String -> Token
floatTok String
mant String
frac Int
expo (String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
digits)) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s
        expo :: Int
expo           = Int -> Int
expSign (Int -> String -> Int
forall a. Num a => a -> String -> a
convertIntegral 10 String
digits)

-- Lex a character literal.
lexChar :: Span -> Lexer Token a
lexChar :: Span -> Lexer Token a
lexChar sp0 :: Span
sp0 _       fail :: FailP a
fail sp :: Span
sp []    = FailP a
fail Span
sp0 "Illegal character constant" Span
sp []
lexChar sp0 :: Span
sp0 success :: SuccessP Token a
success fail :: FailP a
fail sp :: Span
sp (c :: Char
c:s :: String
s)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' = Span -> (Char -> String -> P a) -> FailP a -> P a
forall a. Span -> (Char -> String -> P a) -> FailP a -> P a
lexEscape Span
sp (\d :: Char
d o :: String
o -> Char -> String -> Span -> Lexer Token a
forall a. Char -> String -> Span -> Lexer Token a
lexCharEnd Char
d String
o Span
sp0 SuccessP Token a
success FailP a
fail)
                          FailP a
fail (Span -> Span
nextSpan Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = FailP a
fail Span
sp0 "Illegal character constant" Span
sp (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t' = Char -> String -> Span -> Lexer Token a
forall a. Char -> String -> Span -> Lexer Token a
lexCharEnd Char
c "\t" Span
sp0 SuccessP Token a
success FailP a
fail (Span -> Span
tabSpan  Span
sp) String
s
  | Bool
otherwise = Char -> String -> Span -> Lexer Token a
forall a. Char -> String -> Span -> Lexer Token a
lexCharEnd Char
c [Char
c]  Span
sp0 SuccessP Token a
success FailP a
fail (Span -> Span
nextSpan Span
sp) String
s

-- Lex the end of a character literal.
lexCharEnd :: Char -> String -> Span -> Lexer Token a
lexCharEnd :: Char -> String -> Span -> Lexer Token a
lexCharEnd c :: Char
c o :: String
o sp0 :: Span
sp0 suc :: SuccessP Token a
suc _    sp :: Span
sp ('\'':s :: String
s) = SuccessP Token a
suc Span
sp0 (Char -> String -> Token
charTok Char
c String
o) (Span -> Span
nextSpan Span
sp) String
s
lexCharEnd _ _ sp0 :: Span
sp0 _   fail :: FailP a
fail sp :: Span
sp s :: String
s        =
  FailP a
fail Span
sp0 "Improperly terminated character constant" Span
sp String
s

-- Lex a String literal.
lexString :: Span -> Lexer Token a
lexString :: Span -> Lexer Token a
lexString sp0 :: Span
sp0 suc :: SuccessP Token a
suc fail :: FailP a
fail = String -> (String -> String) -> P a
lexStringRest "" String -> String
forall a. a -> a
id
  where
  lexStringRest :: String -> (String -> String) -> P a
lexStringRest _  _  sp :: Span
sp []    = Span -> Bool -> Context -> CYM a
improperTermination Span
sp
  lexStringRest s0 :: String
s0 so :: String -> String
so sp :: Span
sp (c :: Char
c:s :: String
s)
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = Span -> Bool -> Context -> CYM a
improperTermination Span
sp
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\"' = SuccessP Token a
suc Span
sp0 (String -> String -> Token
stringTok (String -> String
forall a. [a] -> [a]
reverse String
s0) (String -> String
so "")) (Span -> Span
nextSpan Span
sp) String
s
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' = Span
-> String
-> (String -> String)
-> (String -> (String -> String) -> P a)
-> FailP a
-> P a
forall a.
Span
-> String
-> (String -> String)
-> (String -> (String -> String) -> P a)
-> FailP a
-> P a
lexStringEscape Span
sp String
s0 String -> String
so String -> (String -> String) -> P a
lexStringRest FailP a
fail (Span -> Span
nextSpan Span
sp) String
s
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t' = String -> (String -> String) -> P a
lexStringRest (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s0) (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) (Span -> Span
tabSpan  Span
sp) String
s
    | Bool
otherwise = String -> (String -> String) -> P a
lexStringRest (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s0) (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) (Span -> Span
nextSpan Span
sp) String
s
  improperTermination :: Span -> Bool -> Context -> CYM a
improperTermination sp :: Span
sp = FailP a
fail Span
sp0 "Improperly terminated string constant" Span
sp []

-- Lex an escaped character inside a string.
lexStringEscape ::  Span -> String -> (String -> String)
                -> (String -> (String -> String) -> P a)
                -> FailP a -> P a
lexStringEscape :: Span
-> String
-> (String -> String)
-> (String -> (String -> String) -> P a)
-> FailP a
-> P a
lexStringEscape sp0 :: Span
sp0 _  _  _   fail :: FailP a
fail sp :: Span
sp []      = Span -> (Char -> String -> P a) -> FailP a -> P a
forall a. Span -> (Char -> String -> P a) -> FailP a -> P a
lexEscape Span
sp0 Char -> String -> P a
forall a. HasCallStack => a
undefined FailP a
fail Span
sp []
lexStringEscape sp0 :: Span
sp0 s0 :: String
s0 so :: String -> String
so suc :: String -> (String -> String) -> P a
suc fail :: FailP a
fail sp :: Span
sp cs :: String
cs@(c :: Char
c:s :: String
s)
    -- The escape sequence represents an empty character of length zero
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '&'  = String -> (String -> String) -> P a
suc String
s0 (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("\\&" String -> String -> String
forall a. [a] -> [a] -> [a]
++)) (Span -> Span
nextSpan Span
sp) String
s
  | Char -> Bool
isSpace Char
c = (String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
forall a.
(String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
lexStringGap String -> String
so (String -> (String -> String) -> P a
suc String
s0) FailP a
fail Span
sp String
cs
  | Bool
otherwise = Span -> (Char -> String -> P a) -> FailP a -> P a
forall a. Span -> (Char -> String -> P a) -> FailP a -> P a
lexEscape Span
sp0 (\ c' :: Char
c' s' :: String
s' -> String -> (String -> String) -> P a
suc (Char
c'Char -> String -> String
forall a. a -> [a] -> [a]
: String
s0) (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++))) FailP a
fail Span
sp String
cs

-- Lex a string gap.
lexStringGap :: (String -> String) -> ((String -> String) -> P a)
             -> FailP a -> P a
lexStringGap :: (String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
lexStringGap _  _   fail :: FailP a
fail sp :: Span
sp []    = FailP a
fail Span
sp "End-of-file in string gap" Span
sp []
lexStringGap so :: String -> String
so suc :: (String -> String) -> P a
suc fail :: FailP a
fail sp :: Span
sp (c :: Char
c:s :: String
s)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' = (String -> String) -> P a
suc          (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:))          (Span -> Span
nextSpan Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t' = (String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
forall a.
(String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
lexStringGap (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) (String -> String) -> P a
suc FailP a
fail (Span -> Span
tabSpan  Span
sp) String
s
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = (String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
forall a.
(String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
lexStringGap (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) (String -> String) -> P a
suc FailP a
fail (Span -> Span
nlSpan   Span
sp) String
s
  | Char -> Bool
isSpace Char
c = (String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
forall a.
(String -> String) -> ((String -> String) -> P a) -> FailP a -> P a
lexStringGap (String -> String
so (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) (String -> String) -> P a
suc FailP a
fail (Span -> Span
nextSpan Span
sp) String
s
  | Bool
otherwise = FailP a
fail Span
sp ("Illegal character in string gap: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c) Span
sp String
s

-- Lex an escaped character.
lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
lexEscape sp0 :: Span
sp0 suc :: Char -> String -> P a
suc fail :: FailP a
fail sp :: Span
sp str :: String
str = case String
str of
  -- character escape
  ('a' :s :: String
s) -> Char -> String -> P a
suc '\a' "\\a"  (Span -> Span
nextSpan Span
sp) String
s
  ('b' :s :: String
s) -> Char -> String -> P a
suc '\b' "\\b"  (Span -> Span
nextSpan Span
sp) String
s
  ('f' :s :: String
s) -> Char -> String -> P a
suc '\f' "\\f"  (Span -> Span
nextSpan Span
sp) String
s
  ('n' :s :: String
s) -> Char -> String -> P a
suc '\n' "\\n"  (Span -> Span
nextSpan Span
sp) String
s
  ('r' :s :: String
s) -> Char -> String -> P a
suc '\r' "\\r"  (Span -> Span
nextSpan Span
sp) String
s
  ('t' :s :: String
s) -> Char -> String -> P a
suc '\t' "\\t"  (Span -> Span
nextSpan Span
sp) String
s
  ('v' :s :: String
s) -> Char -> String -> P a
suc '\v' "\\v"  (Span -> Span
nextSpan Span
sp) String
s
  ('\\':s :: String
s) -> Char -> String -> P a
suc '\\' "\\\\" (Span -> Span
nextSpan Span
sp) String
s
  ('"' :s :: String
s) -> Char -> String -> P a
suc '\"' "\\\"" (Span -> Span
nextSpan Span
sp) String
s
  ('\'':s :: String
s) -> Char -> String -> P a
suc '\'' "\\\'" (Span -> Span
nextSpan Span
sp) String
s
  -- control characters
  ('^':c :: Char
c:s :: String
s) | Char -> Bool
isControlEsc Char
c -> Char -> P a
controlEsc Char
c (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  -- numeric escape
  ('o':c :: Char
c:s :: String
s) | Char -> Bool
isOctDigit Char
c   -> Int -> (Char -> Bool) -> (String -> String) -> P a
numEsc  8 Char -> Bool
isOctDigit ("\\o" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  ('x':c :: Char
c:s :: String
s) | Char -> Bool
isHexDigit Char
c   -> Int -> (Char -> Bool) -> (String -> String) -> P a
numEsc 16 Char -> Bool
isHexDigit ("\\x" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Span -> Span
nextSpan Span
sp) (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  (c :: Char
c:s :: String
s)     | Char -> Bool
isDigit    Char
c   -> Int -> (Char -> Bool) -> (String -> String) -> P a
numEsc 10 Char -> Bool
isDigit    ("\\"  String -> String -> String
forall a. [a] -> [a] -> [a]
++) Span
sp            (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
  -- ascii escape
  _        -> Span -> (Char -> String -> P a) -> FailP a -> P a
forall a. Span -> (Char -> String -> P a) -> FailP a -> P a
asciiEscape Span
sp0 Char -> String -> P a
suc FailP a
fail Span
sp String
str
  where numEsc :: Int -> (Char -> Bool) -> (String -> String) -> P a
numEsc         = Span
-> (Char -> String -> P a)
-> FailP a
-> Int
-> (Char -> Bool)
-> (String -> String)
-> P a
forall a.
Span
-> (Char -> String -> P a)
-> FailP a
-> Int
-> (Char -> Bool)
-> (String -> String)
-> P a
numEscape Span
sp0 Char -> String -> P a
suc FailP a
fail
        controlEsc :: Char -> P a
controlEsc   c :: Char
c = Char -> String -> P a
suc (Int -> Char
chr (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 32)) ("\\^" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c])
        isControlEsc :: Char -> Bool
isControlEsc c :: Char
c = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "@[\\]^_"

numEscape :: Span -> (Char -> String -> P a) -> FailP a -> Int
          -> (Char -> Bool) -> (String -> String) -> P a
numEscape :: Span
-> (Char -> String -> P a)
-> FailP a
-> Int
-> (Char -> Bool)
-> (String -> String)
-> P a
numEscape sp0 :: Span
sp0 suc :: Char -> String -> P a
suc fail :: FailP a
fail b :: Int
b isDigit' :: Char -> Bool
isDigit' so :: String -> String
so sp :: Span
sp s :: String
s
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Int
ord Char
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
forall a. Bounded a => a
maxBound
   = Char -> String -> P a
suc (Int -> Char
chr Int
n) (String -> String
so String
digits) (Span -> Int -> Span
incrSpan Span
sp (Int -> Span) -> Int -> Span
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits) String
rest
  | Bool
otherwise
  = FailP a
fail Span
sp0 "Numeric escape out-of-range" Span
sp String
s
  where (digits :: String
digits, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit' String
s
        n :: Int
n = Int -> String -> Int
forall a. Num a => a -> String -> a
convertIntegral Int
b String
digits

asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
asciiEscape sp0 :: Span
sp0 suc :: Char -> String -> P a
suc fail :: FailP a
fail sp :: Span
sp str :: String
str = case String
str of
  ('N':'U':'L':s :: String
s) -> Char -> String -> P a
suc '\NUL' "\\NUL" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('S':'O':'H':s :: String
s) -> Char -> String -> P a
suc '\SOH' "\\SOH" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('S':'T':'X':s :: String
s) -> Char -> String -> P a
suc '\STX' "\\STX" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'T':'X':s :: String
s) -> Char -> String -> P a
suc '\ETX' "\\ETX" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'O':'T':s :: String
s) -> Char -> String -> P a
suc '\EOT' "\\EOT" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'N':'Q':s :: String
s) -> Char -> String -> P a
suc '\ENQ' "\\ENQ" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('A':'C':'K':s :: String
s) -> Char -> String -> P a
suc '\ACK' "\\ACK" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('B':'E':'L':s :: String
s) -> Char -> String -> P a
suc '\BEL' "\\BEL" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('B':'S'    :s :: String
s) -> Char -> String -> P a
suc '\BS'  "\\BS"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('H':'T'    :s :: String
s) -> Char -> String -> P a
suc '\HT'  "\\HT"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('L':'F'    :s :: String
s) -> Char -> String -> P a
suc '\LF'  "\\LF"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('V':'T'    :s :: String
s) -> Char -> String -> P a
suc '\VT'  "\\VT"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('F':'F'    :s :: String
s) -> Char -> String -> P a
suc '\FF'  "\\FF"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('C':'R'    :s :: String
s) -> Char -> String -> P a
suc '\CR'  "\\CR"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('S':'O'    :s :: String
s) -> Char -> String -> P a
suc '\SO'  "\\SO"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('S':'I'    :s :: String
s) -> Char -> String -> P a
suc '\SI'  "\\SI"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('D':'L':'E':s :: String
s) -> Char -> String -> P a
suc '\DLE' "\\DLE" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('D':'C':'1':s :: String
s) -> Char -> String -> P a
suc '\DC1' "\\DC1" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('D':'C':'2':s :: String
s) -> Char -> String -> P a
suc '\DC2' "\\DC2" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('D':'C':'3':s :: String
s) -> Char -> String -> P a
suc '\DC3' "\\DC3" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('D':'C':'4':s :: String
s) -> Char -> String -> P a
suc '\DC4' "\\DC4" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('N':'A':'K':s :: String
s) -> Char -> String -> P a
suc '\NAK' "\\NAK" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('S':'Y':'N':s :: String
s) -> Char -> String -> P a
suc '\SYN' "\\SYN" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'T':'B':s :: String
s) -> Char -> String -> P a
suc '\ETB' "\\ETB" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('C':'A':'N':s :: String
s) -> Char -> String -> P a
suc '\CAN' "\\CAN" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'M'    :s :: String
s) -> Char -> String -> P a
suc '\EM'  "\\EM"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('S':'U':'B':s :: String
s) -> Char -> String -> P a
suc '\SUB' "\\SUB" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('E':'S':'C':s :: String
s) -> Char -> String -> P a
suc '\ESC' "\\ESC" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  ('F':'S'    :s :: String
s) -> Char -> String -> P a
suc '\FS'  "\\FS"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('G':'S'    :s :: String
s) -> Char -> String -> P a
suc '\GS'  "\\GS"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('R':'S'    :s :: String
s) -> Char -> String -> P a
suc '\RS'  "\\RS"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('U':'S'    :s :: String
s) -> Char -> String -> P a
suc '\US'  "\\US"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('S':'P'    :s :: String
s) -> Char -> String -> P a
suc '\SP'  "\\SP"  (Span -> Int -> Span
incrSpan Span
sp 2) String
s
  ('D':'E':'L':s :: String
s) -> Char -> String -> P a
suc '\DEL' "\\DEL" (Span -> Int -> Span
incrSpan Span
sp 3) String
s
  s :: String
s               -> FailP a
fail Span
sp0 "Illegal escape sequence" Span
sp String
s