bug fixes in parsing etc; improved ImperC

examples/gfcc/ImperC.gf

@@ -26,10 +26,10 @@ concrete ImperC of Imper = open ResImper in {
       } ;
 
     Decl  typ cont = continues (typ.s ++ cont.$0) cont ;
-    Assign _ x exp = continues (x.s ++ "=" ++ ex exp) ;
-    Return _ exp   = statement ("return" ++ ex exp) ;
-    While exp loop = continue  ("while" ++ paren (ex exp) ++ loop.s) ;
-    IfElse exp t f = continue  ("if" ++ paren (ex exp) ++ t.s ++ "else" ++ f.s) ;
+    Assign _ x exp = continues (x.s ++ "=" ++ exp.s) ;
+    Return _ exp   = statement ("return" ++ exp.s) ;
+    While exp loop = continue  ("while" ++ paren exp.s ++ loop.s) ;
+    IfElse exp t f = continue  ("if" ++ paren exp.s ++ t.s ++ "else" ++ f.s) ;
     Block stm      = continue  ("{" ++ stm.s ++ "}") ;
     End            = ss [] ;
  
@@ -50,6 +50,6 @@ concrete ImperC of Imper = open ResImper in {
     ConsTyp = cc2 ;
 
     NilExp = ss [] ;
-    OneExp _ e = ss (ex e) ;
-    ConsExp _ _ e es = ss (ex e ++ "," ++ es.s) ;
+    OneExp _ e = e ;
+    ConsExp _ _ e es = ss (e.s ++ "," ++ es.s) ;
 }

examples/gfcc/ResImper.gf

@@ -2,27 +2,37 @@ resource ResImper = open Predef in {
 
   -- precedence
 
-  oper 
-    Prec     : PType = Predef.Ints 4 ;
-    PrecExp  : Type = {s : Prec => Str} ;
-    ex       : PrecExp -> Str = \exp -> exp.s ! 0 ;
-    constant : Str -> PrecExp = \c -> {s = \\_ => c} ;
-    infixN : Prec -> Str -> PrecExp -> PrecExp -> PrecExp = \p,f,x,y ->
-      {s = mkPrec (x.s ! (nextPrec ! p) ++ f ++ y.s ! (nextPrec ! p)) ! p} ;
-    infixL : Prec -> Str -> PrecExp -> PrecExp -> PrecExp = \p,f,x,y ->
-      {s = mkPrec (x.s ! p ++ f ++ y.s ! (nextPrec ! p)) ! p} ;
+  param PAssoc = PN | PL | PR ;
 
-    nextPrec : Prec => Prec = table {
+  oper 
+    Prec    : PType = Predef.Ints 4 ;
+    PrecExp : Type = {s : Str ; p : Prec ; a : PAssoc} ;
+
+    mkPrec : Prec -> PAssoc -> Str -> PrecExp = \p,a,f -> 
+      {s = f ; p = p ; a = a} ;
+
+    usePrec : PrecExp -> Prec -> Str = \x,p ->
+      case <<x.p,p> : Prec * Prec> of {
+        <3,4> | <2,3> | <2,4> => paren x.s ;
+        <1,1> | <1,0> | <0,0> => x.s ;
+        <1,_> | <0,_>         => paren x.s ;
+        _ => x.s
+        } ;
+
+    constant : Str -> PrecExp = mkPrec 4 PN ;
+
+    infixN : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y ->
+      mkPrec p PN (usePrec x (nextPrec p) ++ f ++ usePrec y (nextPrec p)) ;
+    infixL : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y ->
+      mkPrec p PL (usePrec x p ++ f ++ usePrec y (nextPrec p)) ;
+    infixR : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y ->
+      mkPrec p PR (usePrec x (nextPrec p) ++ f ++ usePrec y p) ;
+
+    nextPrec : Prec -> Prec = \p -> case <p : Prec> of {
       4 => 4 ; 
       n => Predef.plus n 1
       } ;
 
-    mkPrec : Str -> Prec => Prec => Str = \str -> 
-      \\p,q => case Predef.lessInt p q of {
-        Predef.PTrue => paren str ;
-        _ => str
-        } ;
-
   -- string operations
 
     SS  : Type = {s : Str} ;

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

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

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

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

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]

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

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