mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-12 06:19:33 -06:00
135 lines
4.5 KiB
Haskell
135 lines
4.5 KiB
Haskell
-- -*- haskell -*-
|
|
-- This Alex file was machine-generated by the BNF converter
|
|
-- Lines with -- H have been hacked for greater performance
|
|
{
|
|
module LexGF where
|
|
import SharedString -- H
|
|
import ErrM
|
|
}
|
|
|
|
|
|
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
|
|
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
|
|
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
|
|
$d = [0-9] -- digit
|
|
$i = [$l $d _ '] -- identifier character
|
|
$u = [\0-\255] -- universal: any character
|
|
|
|
@rsyms = -- reserved words consisting of special symbols
|
|
\; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \. | \| | \? | \< | \> | \@ | \! | \* | \\ | \= \> | \+ \+ | \+ | \_ | \$ | \/ | \-
|
|
|
|
:-
|
|
"--" [.]* ; -- Toss single line comments
|
|
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
|
|
|
|
$white+ ;
|
|
@rsyms { tok (\p s -> PT p (TS $ shareString s)) } -- H
|
|
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . shareString) s)) } -- H
|
|
|
|
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . shareString) s)) } -- H
|
|
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail $ shareString s)) } -- H
|
|
|
|
$d+ { tok (\p s -> PT p (TI s)) }
|
|
|
|
|
|
{
|
|
|
|
tok f p s = f p s
|
|
|
|
data Tok =
|
|
TS !String -- reserved words -- H
|
|
| TL !String -- string literals -- H
|
|
| TI String -- integer literals
|
|
| TV !String -- identifiers -- H
|
|
| TD String -- double precision float literals
|
|
| TC String -- character literals
|
|
| T_LString !String -- H
|
|
|
|
deriving (Eq,Show,Ord)
|
|
|
|
data Token =
|
|
PT Posn Tok
|
|
| Err Posn
|
|
deriving (Eq,Show,Ord)
|
|
|
|
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
|
|
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
|
|
tokenPos _ = "end of file"
|
|
|
|
posLineCol (Pn _ l c) = (l,c)
|
|
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
|
|
|
|
prToken t = case t of
|
|
PT _ (TS s) -> s
|
|
PT _ (TI s) -> s
|
|
PT _ (TV s) -> s
|
|
PT _ (TD s) -> s
|
|
PT _ (TC s) -> s
|
|
PT _ (T_LString s) -> s
|
|
|
|
_ -> show t
|
|
|
|
data BTree = N | B String Tok BTree BTree deriving (Show)
|
|
|
|
eitherResIdent :: (String -> Tok) -> String -> Tok
|
|
eitherResIdent tv s = treeFind resWords
|
|
where
|
|
treeFind N = tv s
|
|
treeFind (B a t left right) | s < a = treeFind left
|
|
| s > a = treeFind right
|
|
| s == a = t
|
|
|
|
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
|
|
where b s = B s (TS s)
|
|
|
|
unescapeInitTail :: String -> String
|
|
unescapeInitTail = unesc . tail where
|
|
unesc s = case s of
|
|
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
|
|
'\\':'n':cs -> '\n' : unesc cs
|
|
'\\':'t':cs -> '\t' : unesc cs
|
|
'"':[] -> []
|
|
c:cs -> c : unesc cs
|
|
_ -> []
|
|
|
|
-------------------------------------------------------------------
|
|
-- Alex wrapper code.
|
|
-- A modified "posn" wrapper.
|
|
-------------------------------------------------------------------
|
|
|
|
data Posn = Pn !Int !Int !Int
|
|
deriving (Eq, Show,Ord)
|
|
|
|
alexStartPos :: Posn
|
|
alexStartPos = Pn 0 1 1
|
|
|
|
alexMove :: Posn -> Char -> Posn
|
|
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
|
|
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
|
|
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
|
|
|
|
type AlexInput = (Posn, -- current position,
|
|
Char, -- previous char
|
|
String) -- current input string
|
|
|
|
tokens :: String -> [Token]
|
|
tokens str = go (alexStartPos, '\n', str)
|
|
where
|
|
go :: (Posn, Char, String) -> [Token]
|
|
go inp@(pos, _, str) =
|
|
case alexScan inp 0 of
|
|
AlexEOF -> []
|
|
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
|
|
AlexSkip inp' len -> go inp'
|
|
AlexToken inp' len act -> act pos (take len str) : (go inp')
|
|
|
|
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
|
|
alexGetChar (p, c, []) = Nothing
|
|
alexGetChar (p, _, (c:s)) =
|
|
let p' = alexMove p c
|
|
in p' `seq` Just (c, (p', c, s))
|
|
|
|
alexInputPrevChar :: AlexInput -> Char
|
|
alexInputPrevChar (p, c, s) = c
|
|
}
|