More sharing of reserved words in GF and GFC lexers. Added GF lexer alex file.

4 files changed, 180 insertions, 50 deletions

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)))
-
-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
+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 "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)
+
 
 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
 
-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))))
+data BTree = N | B String Tok BTree BTree deriving (Show)
 
-data BTree = N | B String 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
 
-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 "<built-in>" #-}
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
+}