Lexer by need.

4 files changed, 57 insertions, 17 deletions

diff --git a/src/GF/CF/CF.hs b/src/GF/CF/CF.hs
index 0cff68b97..7c0013548 100644
--- a/src/GF/CF/CF.hs
+++ b/src/GF/CF/CF.hs
@@ -15,8 +15,9 @@ import Char (isUpper, isLower, toUpper, toLower)
 -- abstract type CF. 
 -- Invariant: each category has all its rules grouped with it 
 --      also: the list is never empty (the category is just missing then)
-newtype CF  = CF ([(CFCat,[CFRule])], CFPredef) 
+newtype CF  = CF ([CFRuleGroup], CFPredef) 
 type CFRule = (CFFun, (CFCat, [CFItem]))
+type CFRuleGroup = (CFCat,[CFRule])
 
 -- CFPredef is a hack for variable symbols and literals; normally = const []
 data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show)
diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs
index 02343bfb7..99ab711e4 100644
--- a/src/GF/CF/CFIdent.hs
+++ b/src/GF/CF/CFIdent.hs
@@ -3,7 +3,9 @@ module CFIdent where
 import Operations
 import GFC
 import Ident
+import Values (cPredefAbs)
 import AbsGFC
+import Macros (ident2label)
 import PrGrammar
 import Str
 import Char (toLower, toUpper)
@@ -48,6 +50,10 @@ newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Show)
 
 type Profile  = [([[Int]],[Int])]
 
+wordsCFTok :: CFTok -> [String]
+wordsCFTok t = case t of
+  TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]]
+  _ -> [prCFTok t]
 
 -- the following functions should be used instead of constructors
 
@@ -68,6 +74,9 @@ stringCFFun = mkCFFun . AS
 intCFFun :: Int -> CFFun 
 intCFFun = mkCFFun . AI . toInteger
 
+dummyCFFun :: CFFun
+dummyCFFun = varCFFun $ identC "_" --- used in lexer-by-need rules
+
 cfFun2String :: CFFun -> String
 cfFun2String (CFFun (f,_)) = prt f
 
@@ -105,8 +114,8 @@ cat2CFCat :: (Ident,Ident) -> CFCat
 cat2CFCat = uncurry idents2CFCat
 
 ---- literals
-cfCatString = string2CFCat "Predef" "String"
-cfCatInt = string2CFCat "Predef" "Int"
+cfCatString = string2CFCat (prt cPredefAbs) "String"
+cfCatInt = string2CFCat (prt cPredefAbs) "Int"
 
 
 
@@ -122,6 +131,9 @@ moduleOfCFCat (CFCat (CIQ m _, _)) = m
 cfCat2Cat :: CFCat -> (Ident,Ident)
 cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
 
+lexCFCat :: CFCat -> CFCat
+lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
+
 -- to construct CF tokens
 
 string2CFTok :: String -> CFTok
diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs
index 6651b0100..0950d6244 100644
--- a/src/GF/CF/CanonToCF.hs
+++ b/src/GF/CF/CanonToCF.hs
@@ -5,12 +5,14 @@ import Option
 import Ident
 import AbsGFC
 import GFC
+import Values (isPredefCat,cPredefAbs)
 import PrGrammar
 import CMacros
 import qualified Modules as M
 import CF
 import CFIdent
-import List (nub)
+import Morphology
+import List (nub,partition)
 import Monad
 
 -- AR 27/1/2000 -- 3/12/2001 -- 8/6/2003 
@@ -28,8 +30,8 @@ canon2cf opts gr c = do
   rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms
   let rules = filter (not . isCircularCF) rules0 ---- temporarily here
   let grules = groupCFRules rules
-  let predef = mkCFPredef $ map fst grules
-  return $ CF (grules, predef)
+  let predef = mkCFPredef opts grules
+  return $ CF predef
 
 cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule]
 cnc2cfCond opts m gr = 
@@ -138,16 +140,40 @@ term2CFItems m t = errIn "forming cf items" $ case t of
     tryMkCFTerm itss = return itss
 
     extrR arg lab = case (arg,lab) of
-      (Arg (A cat pos), l@(L _))  -> return [[PNonterm (CIQ m cat) pos l True]]
-      (Arg (A cat pos), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]]
-      (Arg (AB cat pos b), l@(L _))  -> return [[PNonterm (CIQ m cat) pos l True]]
-      (Arg (AB cat pos b), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]]
+      (Arg (A cat pos), l@(L _))  -> return [[PNonterm (cIQ cat) pos l True]]
+      (Arg (A cat pos), l@(LV _)) -> return [[PNonterm (cIQ cat) pos l False]]
+      (Arg (AB cat pos b), l@(L _))  -> return [[PNonterm (cIQ cat) pos l True]]
+      (Arg (AB cat pos b), l@(LV _)) -> return [[PNonterm (cIQ cat) pos l False]]
                                      ---- ??
       _   -> prtBad "cannot extract record field from" arg
-
-mkCFPredef :: [CFCat] -> CFPredef
-mkCFPredef cats s = 
-  [(cat,         metaCFFun)     | TM _ _ <- [s], cat <- cats] ++
-  [(cat,         varCFFun x)    | TV x   <- [s], cat <- cats] ++
-  [(cfCatString, stringCFFun t) | TL t   <- [s]]              ++
-  [(cfCatInt,    intCFFun t)    | TI t   <- [s]]
+    cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c
+
+mkCFPredef :: Options -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef)
+mkCFPredef opts rules = (ruls, \s -> preds0 s ++ look s) where
+  (ruls,preds) = if oElem lexerByNeed opts  -- option -cflexer
+                   then predefLexer rules 
+                   else (rules,NT)
+  preds0 s = 
+    [(cat,         metaCFFun)     | TM _ _ <- [s], cat <- cats] ++
+    [(cat,         varCFFun x)    | TV x   <- [s], cat <- cats] ++
+    [(cfCatString, stringCFFun t) | TL t   <- [s]]              ++
+    [(cfCatInt,    intCFFun t)    | TI t   <- [s]]
+  cats = map fst rules
+  look s = errVal [] $ liftM concat $ 
+             mapM (flip justLookupTree preds . tS) $ wordsCFTok s --- for TC tokens
+
+--- TODO: use trie instead of bintree; integrate with morphology
+predefLexer :: [CFRuleGroup] -> ([CFRuleGroup],BinTree (CFTok,[(CFCat, CFFun)]))
+predefLexer groups = (reverse ruls, sorted2tree $ sortAssocs preds) where
+  (ruls,preds) = foldr mkOne ([],[]) groups
+  mkOne group@(cat,rules) (rs,ps) = (rule:rs,pre ++ ps) where
+    (rule,pre) = case partition isLexical rules of
+      ([],_) -> (group,[])
+      (ls,rest) -> ((cat,rest), concatMap mkLexRule ls) --- useLexRule cat : rest
+  isLexical (f,(c,its)) = case its of
+    [CFTerm (RegAlts ws)] -> True
+    _ -> False
+--  useLexRule cat = (dummyCFFun,(cat,[CFNonterm (lexCFCat cat)])) -- not needed
+  mkLexRule r = case r of
+    (fun,(cat,[CFTerm (RegAlts ws)])) -> [(tS w, (cat,fun)) | w <- ws]
+    _ -> []
diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs
index 6dbb5f85a..1b821d53a 100644
--- a/src/GF/CF/Profile.hs
+++ b/src/GF/CF/Profile.hs
@@ -33,6 +33,7 @@ type BindVs = [[I.Ident]]
 -- (2) term2trm:  restore Bindings from Binds
 
 tree2term :: CFTree -> Err ITerm
+-- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used
 tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
   AM _ -> return IMeta
   _ -> do