module Curry.Syntax.Lexer
(
Token (..), Category (..), Attributes (..)
, 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
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)
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
| Bool
isComment -> (Int
ld, Int
cd)
| '\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
data Category
= CharTok
| IntTok
| FloatTok
| StringTok
| Id
| QId
| Sym
| QSym
| LeftParen
| RightParen
| Semicolon
| LeftBrace
| RightBrace
| LeftBracket
| RightBracket
| Comma
| Underscore
| Backquote
| VSemicolon
| VRightBrace
| 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
| At
| Colon
| DotDot
| DoubleColon
| Equals
| Backslash
| Bar
| LeftArrow
| RightArrow
| Tilde
| DoubleArrow
| Id_as
| Id_ccall
| Id_forall
| Id_hiding
| Id_interface
| Id_primitive
| Id_qualified
| SymDot
| SymMinus
| SymStar
| PragmaLanguage
| PragmaOptions
| PragmaHiding
| PragmaMethod
| PragmaModule
| PragmaEnd
|
|
| 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)
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)
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>"
tok :: Category -> Token
tok :: Category -> Token
tok t :: Category
t = Category -> Attributes -> Token
Token Category
t Attributes
NoAttributes
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 }
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 }
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 }
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 }
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 }
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 }
lineCommentTok :: String -> Token
s :: String
s = Category -> Attributes -> Token
Token Category
LineComment
StringAttributes :: String -> String -> Attributes
StringAttributes { sval :: String
sval = String
s, original :: String
original = String
s }
nestedCommentTok :: String -> Token
s :: String
s = Category -> Attributes -> Token
Token Category
NestedComment
StringAttributes :: String -> String -> Attributes
StringAttributes { sval :: String
sval = String
s, original :: String
original = String
s }
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 )
]
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 )
]
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 )
]
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 )
]
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` "'_"
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` "~!@#$%^&*+-=<>:?./|\\"
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)
lexer :: Lexer Token a
lexer :: Lexer Token a
lexer = Bool -> Lexer Token a
forall a. Bool -> Lexer Token a
skipWhiteSpace Bool
True
fullLexer :: Lexer Token a
fullLexer :: Lexer Token a
fullLexer = Bool -> Lexer Token a
forall a. Bool -> Lexer Token a
skipWhiteSpace Bool
False
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
lexLineComment :: Lexer Token a
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
lexNestedComment :: Lexer Token a
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
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')
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
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
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)
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
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
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)
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
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
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
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
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'
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
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
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
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
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
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)
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
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
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 []
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)
| 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
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
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
('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
('^':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
('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)
_ -> 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