bug fixes in parsing etc; improved ImperC

7 files changed, 32 insertions, 6 deletions

diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs
index 915e11db2..58674e189 100644
--- a/src/GF/CF/CanonToCF.hs
+++ b/src/GF/CF/CanonToCF.hs
@@ -6,6 +6,7 @@ import Operations
 import Option
 import Ident
 import AbsGFC
+import LookAbs (allBindCatsOf)
 import GFC
 import Values (isPredefCat,cPredefAbs)
 import PrGrammar
@@ -31,9 +32,10 @@ canon2cf opts gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ d
   let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms]
   let mms  = [(a, tree2list (M.jments m)) | m <- cncs]
   rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms
+  let bindcats = map snd $ allBindCatsOf gr 
   let rules = filter (not . isCircularCF) rules0 ---- temporarily here
   let grules = groupCFRules rules
-  let predef = mkCFPredef opts grules
+  let predef = mkCFPredef opts bindcats grules
   return $ CF predef
 
 cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule]
@@ -151,17 +153,18 @@ term2CFItems m t = errIn "forming cf items" $ case t of
       _   -> prtBad "cannot extract record field from" arg
     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
+mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef)
+mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where
   (ruls,preds) = if oElem lexerByNeed opts  -- option -cflexer
                    then predefLexer rules 
                    else (rules,emptyTrie)
   preds0 s = 
     [(cat,         metaCFFun)     | TM _ _ <- [s], cat <- cats] ++
-    [(cat,         varCFFun x)    | TV x   <- [s], cat <- catVarCF : cats] ++
+    [(cat,         varCFFun x)    | TV x   <- [s], cat <- catVarCF : bindcats] ++
     [(cfCatString, stringCFFun t) | TL t   <- [s]]              ++
     [(cfCatInt,    intCFFun t)    | TI t   <- [s]]
-  cats = map fst rules
+  cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its]
+  bindcats = [c | c <- cats, elem (cfCat2Ident c) binds]
   look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens
 
 --- TODO: integrate with morphology
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 8f152ff17..74256d66b 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -309,6 +309,11 @@ inferLType gr trm = case trm of
 
    Vr ident -> termWith trm $ checkLookup ident
 
+   Typed e t -> do
+     t' <- comp t
+     check e t'
+     return (e,t')
+
    App f a -> do
      (f',fty) <- infer f
      fty' <- comp fty
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index bb54df050..61ff8de32 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -166,6 +166,7 @@ mkLinDefault gr typ = do
        let (ls,ts) = unzip r
        ts' <- mapM mkDefField ts
        return $ R $ [assign l t | (l,t) <- zip ls ts']
+     _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
      _ -> prtBad "linearization type field cannot be" typ
 
 -- Form the printname: if given, compute. If not, use the computed
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 6c3f964df..55708f629 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -158,6 +158,7 @@ renameTerm env vars = ren vars where
   ren vs trm = case trm of
     Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
     Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
     Vr x      
       | elem x vs -> return trm
       | otherwise -> renid trm
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
index 06e3ce3a5..ba809822a 100644
--- a/src/GF/Grammar/LookAbs.hs
+++ b/src/GF/Grammar/LookAbs.hs
@@ -105,6 +105,15 @@ allCatsOf gr =
                     isModAbs m,
                     (c, C.AbsCat cont _) <- tree2list (jments m)]
 
+allBindCatsOf :: GFCGrammar -> [Cat]
+allBindCatsOf gr = 
+  nub [c | (i, ModMod m) <- modules gr,
+                    isModAbs m,
+                    (c, C.AbsFun typ _) <- tree2list (jments m),
+                    Ok (cont,_) <- [firstTypeForm typ],
+                    c <- concatMap fst $ errVal [] $ mapM (catSkeleton . snd) cont
+                    ]
+
 funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)]
 funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, 
                                          compat val typ]
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index f11b9bbe9..8b9f825b5 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -273,6 +273,10 @@ typeString = constPredefRes "String"
 typeInt = constPredefRes "Int"
 typeInts i = App (constPredefRes "Ints") (EInt i)
 
+isTypeInts ty = case ty of
+  App c _ -> c == constPredefRes "Ints"
+  _ -> False
+
 constPredefRes s = Q (IC "Predef") (zIdent s)
 
 isPredefConstant t = case t of
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index 436ce4503..38a55e4d5 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -353,7 +353,10 @@ transExp x = case x of
   ECase exp cases  -> do
     exp' <- transExp exp
     cases' <- transCases cases
-    return $ G.S (G.T G.TRaw cases') exp'
+    let annot = case exp' of
+          G.Typed _ t -> G.TTyped t
+          _ -> G.TRaw 
+    return $ G.S (G.T annot cases') exp'
   ECTable binds exp  -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
 
   EVariants exps    -> liftM G.FV $ mapM transExp exps