diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs index e02f23d77..db745f20f 100644 --- a/src/GF/Canon/LexGFC.hs +++ b/src/GF/Canon/LexGFC.hs @@ -65,20 +65,19 @@ prToken t = case t of _ -> show t +data BTree = N | B String Tok BTree BTree deriving (Show) + eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where - isResWord s = isInTree s $ - B "lin" (B "concrete" (B "Type" (B "Str" (B "Ints" N N) N) (B "cat" (B "abstract" N N) N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" (B "grammar" N N) N))) (B "pre" (B "open" (B "of" (B "lincat" N N) N) (B "param" (B "oper" N N) N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N))) +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 -data BTree = N | B String BTree BTree deriving (Show) +resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) + where b s = B s (TS s) -isInTree :: String -> BTree -> Bool -isInTree x tree = case tree of - N -> False - B a left right - | x < a -> isInTree x left - | x > a -> isInTree x right - | x == a -> True unescapeInitTail :: String -> String unescapeInitTail = unesc . tail where @@ -130,7 +129,7 @@ alexGetChar (p, _, (c:s)) = alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p, c, s) = c -alex_action_1 = tok (\p s -> PT p (TS (shareString s))) +alex_action_1 = tok (\p s -> PT p (TS $ shareString s)) alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . shareString) s)) alex_action_3 = tok (\p s -> PT p (TL $ unescapeInitTail $ shareString s)) alex_action_4 = tok (\p s -> PT p (TI s)) diff --git a/src/GF/Canon/LexGFC.x b/src/GF/Canon/LexGFC.x index c9697c270..2f7b2180c 100644 --- a/src/GF/Canon/LexGFC.x +++ b/src/GF/Canon/LexGFC.x @@ -21,10 +21,10 @@ $u = [\0-\255] -- universal: any character :- $white+ ; -@rsyms { tok (\p s -> PT p (TS (shareString s))) } -- H +@rsyms { tok (\p s -> PT p (TS $ shareString s)) } $l $i* { tok (\p s -> PT p (eitherResIdent (TV . shareString) s)) } -- H -\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ shareString $ unescapeInitTail s)) } -- H +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail $ shareString s)) } -- H $d+ { tok (\p s -> PT p (TI s)) } @@ -64,20 +64,19 @@ prToken t = case t of _ -> show t +data BTree = N | B String Tok BTree BTree deriving (Show) + eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where - isResWord s = isInTree s $ - B "lin" (B "concrete" (B "Type" (B "Str" (B "Ints" N N) N) (B "cat" (B "abstract" N N) N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" (B "grammar" N N) N))) (B "pre" (B "open" (B "of" (B "lincat" N N) N) (B "param" (B "oper" N N) N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N))) +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 -data BTree = N | B String BTree BTree deriving (Show) +resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) + where b s = B s (TS s) -isInTree :: String -> BTree -> Bool -isInTree x tree = case tree of - N -> False - B a left right - | x < a -> isInTree x left - | x > a -> isInTree x right - | x == a -> True unescapeInitTail :: String -> String unescapeInitTail = unesc . tail where diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs index c62b34feb..dc6af5e33 100644 --- a/src/GF/Source/LexGF.hs +++ b/src/GF/Source/LexGF.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "LexGF.x" #-} +{-# LINE 4 "LexGF.x" #-} module LexGF where - +import SharedString -- H import ErrM #if __GLASGOW_HASKELL__ >= 503 @@ -30,18 +30,18 @@ alex_deflt :: AlexAddr alex_deflt = AlexA# "\x15\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\x14\x00\xff\xff\xff\xff\xff\xff\x19\x00\x19\x00\xff\xff\xff\xff"# alex_accept = listArray (0::Int,27) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))]] -{-# LINE 34 "LexGF.x" #-} +{-# LINE 35 "LexGF.x" #-} tok f p s = f p s data Tok = - TS String -- reserved words - | TL String -- string literals + TS !String -- reserved words -- H + | TL !String -- string literals -- H | TI String -- integer literals - | TV String -- identifiers + | TV !String -- identifiers -- H | TD String -- double precision float literals | TC String -- character literals - | T_LString String + | T_LString !String -- H deriving (Eq,Show,Ord) @@ -67,20 +67,18 @@ prToken t = case t of _ -> show t +data BTree = N | B String Tok BTree BTree deriving (Show) + eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where - isResWord s = isInTree s $ - 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)))) +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 -data BTree = N | B String BTree BTree deriving (Show) - -isInTree :: String -> BTree -> Bool -isInTree x tree = case tree of - N -> False - B a left right - | x < a -> isInTree x left - | x > a -> isInTree x right - | x == a -> True +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 @@ -132,10 +130,10 @@ alexGetChar (p, _, (c:s)) = alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p, c, s) = c -alex_action_3 = tok (\p s -> PT p (TS s)) -alex_action_4 = tok (\p s -> PT p (eitherResIdent T_LString s)) -alex_action_5 = tok (\p s -> PT p (eitherResIdent TV s)) -alex_action_6 = tok (\p s -> PT p (TL $ unescapeInitTail s)) +alex_action_3 = tok (\p s -> PT p (TS $ shareString s)) +alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_LString . shareString) s)) +alex_action_5 = tok (\p s -> PT p (eitherResIdent (TV . shareString) s)) +alex_action_6 = tok (\p s -> PT p (TL $ unescapeInitTail $ shareString s)) alex_action_7 = tok (\p s -> PT p (TI s)) {-# LINE 1 "GenericTemplate.hs" #-} {-# LINE 1 "" #-} diff --git a/src/GF/Source/LexGF.x b/src/GF/Source/LexGF.x new file mode 100644 index 000000000..6894276d1 --- /dev/null +++ b/src/GF/Source/LexGF.x @@ -0,0 +1,134 @@ +-- -*- 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 +}