gf-3.12: src/compiler/GF/Grammar/Lexer.x
-- -*- haskell -*-
{
{-# LANGUAGE CPP #-}
module GF.Grammar.Lexer
( Token(..), Posn(..)
, P, runP, runPartial, token, lexer, getPosn, failLoc
, isReservedWord, invMap
) where
import Control.Applicative
import Control.Monad(ap)
import GF.Infra.Ident
--import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString as WBS
import qualified Data.ByteString.Internal as BS(w2c)
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as Map
import Data.Word(Word8)
import Data.Char(readLitChar)
--import Debug.Trace(trace)
import qualified Control.Monad.Fail as Fail
}
$l = [a-zA-Z\192 - \255] # [\215 \247]
$c = [A-Z\192-\221] # [\215]
$s = [a-z\222-\255] # [\247]
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [.\n] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ | \: \= | \: \: \=
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok ident }
\' ([. # [\' \\ \n]] | (\\ (\' | \\)))+ \' { tok (T_Ident . identS . unescapeInitTail . unpack) }
(\_ | $l)($l | $d | \_ | \')* { tok ident }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t | $d+)))* \" { tok (T_String . unescapeInitTail . unpack) }
(\-)? $d+ { tok (T_Integer . read . unpack) }
(\-)? $d+ \. $d+ (e (\-)? $d+)? { tok (T_Double . read . unpack) }
{
unpack = UTF8.toString
--unpack = id
ident = res T_Ident . identC . rawIdentC
tok f p s = f s
data Token
= T_exclmark
| T_patt
| T_int_label
| T_oparen
| T_cparen
| T_tilde
| T_star
| T_starstar
| T_plus
| T_plusplus
| T_comma
| T_minus
| T_rarrow
| T_dot
| T_alt
| T_colon
| T_semicolon
| T_less
| T_equal
| T_big_rarrow
| T_great
| T_questmark
| T_obrack
| T_lam
| T_lamlam
| T_cbrack
| T_ocurly
| T_bar
| T_ccurly
| T_underscore
| T_at
| T_cfarrow
| T_PType
| T_Str
| T_Strs
| T_Tok
| T_Type
| T_abstract
| T_case
| T_cat
| T_concrete
| T_data
| T_def
| T_flags
| T_fn
| T_fun
| T_in
| T_incomplete
| T_instance
| T_interface
| T_let
| T_lin
| T_lincat
| T_lindef
| T_linref
| T_of
| T_open
| T_oper
| T_param
| T_pattern
| T_pre
| T_printname
| T_resource
| T_strs
| T_table
| T_transfer
| T_variants
| T_where
| T_with
| T_coercions
| T_terminator
| T_separator
| T_nonempty
| T_String String -- string literals
| T_Integer Int -- integer literals
| T_Double Double -- double precision float literals
| T_Ident Ident
| T_EOF
deriving (Eq, Ord, Show) -- debug
res = eitherResIdent
eitherResIdent :: (Ident -> Token) -> Ident -> Token
eitherResIdent tv s =
case Map.lookup s resWords of
Just t -> t
Nothing -> tv s
isReservedWord :: Ident -> Bool
isReservedWord ident = Map.member ident resWords
resWords = Map.fromList
[ b "!" T_exclmark
, b "#" T_patt
, b "$" T_int_label
, b "(" T_oparen
, b ")" T_cparen
, b "~" T_tilde
, b "*" T_star
, b "**" T_starstar
, b "+" T_plus
, b "++" T_plusplus
, b "," T_comma
, b "-" T_minus
, b "->" T_rarrow
, b "." T_dot
, b "/" T_alt
, b ":" T_colon
, b ";" T_semicolon
, b "<" T_less
, b "=" T_equal
, b "=>" T_big_rarrow
, b ">" T_great
, b "?" T_questmark
, b "[" T_obrack
, b "]" T_cbrack
, b "\\" T_lam
, b "\\\\" T_lamlam
, b "{" T_ocurly
, b "}" T_ccurly
, b "|" T_bar
, b "_" T_underscore
, b "@" T_at
, b "::=" T_cfarrow
, b ":=" T_cfarrow
, b "PType" T_PType
, b "Str" T_Str
, b "Strs" T_Strs
, b "Tok" T_Tok
, b "Type" T_Type
, b "abstract" T_abstract
, b "case" T_case
, b "cat" T_cat
, b "concrete" T_concrete
, b "data" T_data
, b "def" T_def
, b "flags" T_flags
, b "fn" T_fn
, b "fun" T_fun
, b "in" T_in
, b "incomplete" T_incomplete
, b "instance" T_instance
, b "interface" T_interface
, b "let" T_let
, b "lin" T_lin
, b "lincat" T_lincat
, b "lindef" T_lindef
, b "linref" T_linref
, b "of" T_of
, b "open" T_open
, b "oper" T_oper
, b "param" T_param
, b "pattern" T_pattern
, b "pre" T_pre
, b "printname" T_printname
, b "resource" T_resource
, b "strs" T_strs
, b "table" T_table
, b "transfer" T_transfer
, b "variants" T_variants
, b "where" T_where
, b "with" T_with
, b "coercions" T_coercions
, b "terminator" T_terminator
, b "separator" T_separator
, b "nonempty" T_nonempty
]
where b s t = (identS s, t)
invMap :: Map.Map Token String
invMap = res
where
lst = Map.toList resWords
flp = map (\(k,v) -> (v,showIdent k)) lst
res = Map.fromList flp
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
[] -> []
'\"':[] -> []
'\'':[] -> []
_ -> case readLitChar s of
[(c,cs)] -> c:unesc cs
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn {-# UNPACK #-} !Int
{-# UNPACK #-} !Int
deriving (Eq,Show)
alexMove :: Posn -> Char -> Posn
alexMove (Pn l c) '\n' = Pn (l+1) 1
alexMove (Pn l c) _ = Pn l (c+1)
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
alexGetByte (AI p _ s) =
case WBS.uncons s of
Nothing -> Nothing
Just (w,s) ->
let p' = alexMove p c
c = BS.w2c w
in p' `seq` Just (w, (AI p' c s))
{-
-- Not used by this lexer:
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI p c s) = c
-}
data AlexInput = AI {-# UNPACK #-} !Posn -- current position,
{-# UNPACK #-} !Char -- previous char
{-# UNPACK #-} !BS.ByteString -- current input string
type AlexInput2 = (AlexInput,AlexInput)
data ParseResult a
= POk AlexInput2 a
| PFailed Posn -- The position of the error
String -- The error message
newtype P a = P { unP :: AlexInput2 -> ParseResult a }
instance Functor P where
fmap = liftA
instance Applicative P where
pure a = a `seq` (P $ \s -> POk s a)
(<*>) = ap
instance Monad P where
return = pure
(P m) >>= k = P $ \ s -> case m s of
POk s a -> unP (k a) s
PFailed posn err -> PFailed posn err
#if !(MIN_VERSION_base(4,13,0))
-- Monad(fail) will be removed in GHC 8.8+
fail = Fail.fail
#endif
instance Fail.MonadFail P where
fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg
runP :: P a -> BS.ByteString -> Either (Posn,String) a
runP p bs = snd <$> runP' p (Pn 1 0,bs)
runPartial p s = conv <$> runP' p (Pn 1 0,UTF8.fromString s)
where conv ((pos,rest),x) = (UTF8.toString rest,x)
runP' (P f) (pos,txt) =
case f (dup (AI pos ' ' txt)) of
POk (AI pos _ rest,_) x -> Right ((pos,rest),x)
PFailed pos msg -> Left (pos,msg)
dup x = (x,x)
failLoc :: Posn -> String -> P a
failLoc pos msg = P $ \_ -> PFailed pos msg
lexer :: (Token -> P a) -> P a
lexer cont = cont=<<token
token :: P Token
token = P go
where
--cont' t = trace (show t) (cont t)
go ai2@(_,inp@(AI pos _ str)) =
case alexScan inp 0 of
AlexEOF -> POk (inp,inp) T_EOF
AlexError (AI pos _ _) -> PFailed pos "lexical error"
AlexSkip inp' len -> {-trace (show len) $-} go (inp,inp')
AlexToken inp' len act -> POk (inp,inp') (act pos ({-UTF8.toString-} (UTF8.take len str)))
getPosn :: P Posn
getPosn = P $ \ai2@(_,inp@(AI pos _ _)) -> POk ai2 pos
}