printing to LBNF with profiles

examples/gfcc/Imper.gf

@@ -1,8 +1,9 @@
-abstract Imper = {
+abstract Imper = PredefAbs ** {
 
   cat
     Program ;
     Typ ;
+    NumTyp ;
     ListTyp ;
     Fun ListTyp Typ ;
     Body ListTyp ;
@@ -17,6 +18,7 @@ abstract Imper = {
               Body AS -> (Fun AS V -> Program) -> Program ;
 
     BodyNil  : Stm -> Body NilTyp ;
+    BodyOne  : (A : Typ) -> (Var A -> Stm) -> Body (ConsTyp A NilTyp) ;
     BodyCons : (A : Typ) -> (AS : ListTyp) -> 
                   (Var A -> Body AS) -> Body (ConsTyp A AS) ;
 
@@ -29,22 +31,20 @@ abstract Imper = {
     End    : Stm ;
 
     EVar   : (A : Typ) -> Var A -> Exp A ;
-    EInt   : Int -> Exp TInt ;
+    EInt   : Int -> Exp (TNum TInt) ;
-    EFloat : Int -> Int -> Exp TFloat ;
+    EFloat : Int -> Int -> Exp (TNum TFloat) ;
-    ELtI   : Exp TInt -> Exp TInt -> Exp TInt ;
+    ELt    : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Exp (TNum TInt) ;
-    ELtF   : Exp TFloat -> Exp TFloat -> Exp TInt ;
     EApp   : (AS : ListTyp) -> (V : Typ) -> Fun AS V -> ListExp AS -> Exp V ;
-    EAddI, EMulI, ESubI : Exp TInt -> Exp TInt -> Exp TInt ;
+    EAdd, EMul, ESub : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Ex ;
-    EAddF, EMulF, ESubF : Exp TFloat -> Exp TFloat -> Exp TFloat ;
+
-  
+    TNum   : NumTyp -> Typ ;  
-    TInt   : Typ ;
+    TInt, TFloat : NumTyp ;
-    TFloat : Typ ;
 
     NilTyp  : ListTyp ;
     ConsTyp : Typ -> ListTyp -> ListTyp ;
 
     NilExp  : ListExp NilTyp ;
+    OneExp  : (A : Typ) -> Exp A -> ListExp (ConsTyp A NilTyp) ;
     ConsExp : (A : Typ) -> (AS : ListTyp) -> 
-                 Exp A -> ListExp AS -> ListExp (ConsExp A AS) ;
+                 Exp A -> ListExp AS -> ListExp (ConsTyp A AS) ;
-
 }

examples/gfcc/ImperC.gf

@@ -1,10 +1,10 @@
+--# -path=.:../prelude
 concrete ImperC of Imper = open ResImper in {
   flags lexer=codevars ; unlexer=code ; startcat=Stm ;
 
   lincat
     Exp = PrecExp ;
-    Body = {s,s2 : Str ; size : Size} ;
+    Body = {s,s2 : Str} ;
-    ListExp = {s    : Str ; size : Size} ;
 
   lin
     Empty = ss [] ;
@@ -12,11 +12,13 @@ concrete ImperC of Imper = open ResImper in {
       val.s ++ cont.$0 ++ paren body.s2 ++ "{" ++ 
       body.s ++ "}" ++ ";" ++ cont.s) ;
 
-    BodyNil stm = stm ** {s2 = [] ; size = Zero} ;
+    BodyNil stm = stm ** {s2 = []} ;
+    BodyOne typ stm = stm ** {
+      s2 = typ.s ++ stm.$0
+      } ;
     BodyCons typ _ body = {
       s  = body.s ; 
-      s2 = typ.s ++ body.$0 ++ separator "," body.size ++ body.s2 ;
+      s2 = typ.s ++ body.$0 ++ "," ++ body.s2 ;
-      size = nextSize body.size
       } ;
 
     Decl  typ cont = continues (typ.s ++ cont.$0) cont ;
@@ -27,24 +29,23 @@ concrete ImperC of Imper = open ResImper in {
     Block stm      = continue  ("{" ++ stm.s ++ "}") ;
     End            = ss [] ;
  
-    EVar  _ x    = constant x.s ;
+    EVar  _ x  = constant x.s ;
-    EInt    n    = constant n.s ;
+    EInt    n  = constant n.s ;
-    EFloat a b   = constant (a.s ++ "." ++ b.s) ;
+    EFloat a b = constant (a.s ++ "." ++ b.s) ;
-    EMulI, EMulF = infixL P2 "*" ;
+    EMul _     = infixL P2 "*" ;
-    EAddI, EAddF = infixL P1 "+" ;
+    EAdd _     = infixL P1 "+" ;
-    ESubI, ESubF = infixL P1 "-" ;
+    ESub _     = infixL P1 "-" ;
-    ELtI,  ELtF  = infixN P0 "<" ;
+    ELt _      = infixN P0 "<" ;
 
     EApp args val f exps = constant (f.s ++ paren exps.s) ;
 
+    TNum t  = t ;
     TInt    = ss "int" ;
     TFloat  = ss "float" ;
     NilTyp  = ss [] ;
     ConsTyp = cc2 ;
 
-    NilExp = ss [] ** {size = Zero} ;
+    NilExp = ss [] ;
-    ConsExp _ _ e es = {
+    OneExp _ e = ss (ex e) ;
-      s = ex e ++ separator "," es.size ++ es.s ;
+    ConsExp _ _ e es = ss (ex e ++ "," ++ es.s) ;
-      size = nextSize es.size
-      } ;
 }

src/GF/CF/PrLBNF.hs

@@ -11,14 +11,16 @@ import Char
 
 -- Printing CF grammars generated from GF as LBNF grammar for BNFC.
 -- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003
--- With a primitive error messaging, by rules and rule tails commented out
+-- With primitive error messaging, by rules and rule tails commented out
 
 prLBNF :: CF -> String
-prLBNF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function
+prLBNF cf = unlines $ (map (prCFRule cs)) $ rulesOfCF cf --- no literal recogn function
+  where    
+    cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rulesOfCF cf]
 
 -- a hack to hide the LBNF details
 prBNF :: CF -> String
-prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOfCF 
+prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF
   where
     unLBNF r = case r of
       "---":ts -> ts
@@ -26,25 +28,35 @@ prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOf
       c:ts -> c : unLBNF ts
       _ -> r
 
-prCFRule :: CFRule -> String
+catId ((CFCat ((CIQ _ c),l))) = c
-prCFRule (fun,(cat,its)) = 
-  prCFFun fun ++ "." +++ prCFCat True cat +++ "::=" +++  --- err in cat -> in syntax
-  unwords (map prCFItem its) +++ ";"
 
-prCFFun :: CFFun -> String
+prCFRule :: [Ident] -> CFRule -> String
-prCFFun (CFFun (t, p)) = case t of
+prCFRule cs (fun,(cat,its)) = 
-  AC (CIQ _ x) -> prId True x
+  prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++  --- err in cat -> in syntax
-  AD (CIQ _ x) -> prId True x
+  unwords (map (prCFItem cs) its) +++ ";"
+
+prCFFun :: CFCat -> CFFun -> String
+prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of
+  AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
+  AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
   _ -> prErr True $ prt t
+ where
+   lab = prLab l
+   f2 f = if null lab then "" else f
+   prP = concatMap show
    
 prId b i = case i of
-     IC "Int" -> "Integer"
+     IC "Int"  -> "Integer"
+     IC "#Var" -> "Ident"
+     IC "Var"  -> "Ident"
+     IC "id_"  -> "_"
      IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else ""
      _ -> prErr b $ prt i
 
 prLab i = case i of
      L (IC "s") -> "" ---
-     _ -> "_" ++ prt i
+     L (IC "_") -> "" ---
+     _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else ""
 
 -- just comment out the rest if you cannot interpret the function name in LBNF
 -- two versions, depending on whether in the beginning of a rule or elsewhere;
@@ -55,8 +67,9 @@ prErr b s = (if b then "" else " ;") +++ "---" +++ s
 prCFCat :: Bool -> CFCat -> String
 prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ----
 
-prCFItem (CFNonterm c) = prCFCat False c
+-- if a category does not have a production of its own, we replace it by Ident
-prCFItem (CFTerm a) = prRegExp a
+prCFItem cs (CFNonterm c) = if elem (catId c) cs then prCFCat False c else "Ident"
+prCFItem _ (CFTerm a) = prRegExp a
 
 prRegExp (RegAlts tt) = case tt of
   [t] -> prQuotedString t

src/GF/Compile/CheckGrammar.hs

@@ -78,15 +78,32 @@ checkAbsInfo st m (c,info) = do
  case info of
    AbsCat (Yes cont) _ -> mkCheck "category" $ 
      checkContext st cont ---- also cstrs
-   AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ 
+   AbsFun (Yes typ0) md -> do
-     checkTyp st typ ----- ++ 
+    typ <- compAbsTyp [] typ0   -- to calculate let definitions
-     ----- checkEquation st (m,c) d  ---- also if there's no def!
+    mkCheck "function" $
+       checkTyp st typ ++ 
+       case md of
+         Yes d ->  checkEquation st (m,c) d
+         _ -> []
+    return $ (c,AbsFun (Yes typ) md)
    _ -> return (c,info)
  where
    mkCheck cat ss = case ss of
      [] -> return (c,info)
      ["[]"] -> return (c,info) ----
      _  -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
+   compAbsTyp g t = case t of
+     Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
+     Let (x,(_,a)) b -> do
+       a' <- compAbsTyp g a
+       compAbsTyp ((x, a'):g) b
+     Prod x a b -> do
+       a' <- compAbsTyp g a
+       b' <- compAbsTyp ((x,Vr x):g) b
+       return $ Prod x a' b'
+     Abs _ _ -> return t
+     _ -> composOp (compAbsTyp g) t
+
 
 checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check ()
 checkCompleteGrammar abs cnc = mapM_ checkWarn $