printing to LBNF with profiles

2 files changed, 48 insertions, 18 deletions

diff --git a/src/GF/CF/PrLBNF.hs b/src/GF/CF/PrLBNF.hs
index 59067c39b..701674a52 100644
--- a/src/GF/CF/PrLBNF.hs
+++ b/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
-prCFRule (fun,(cat,its)) = 
-  prCFFun fun ++ "." +++ prCFCat True cat +++ "::=" +++  --- err in cat -> in syntax
-  unwords (map prCFItem its) +++ ";"
+catId ((CFCat ((CIQ _ c),l))) = c
 
-prCFFun :: CFFun -> String
-prCFFun (CFFun (t, p)) = case t of
-  AC (CIQ _ x) -> prId True x
-  AD (CIQ _ x) -> prId True x
+prCFRule :: [Ident] -> CFRule -> String
+prCFRule cs (fun,(cat,its)) = 
+  prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++  --- err in cat -> in syntax
+  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
-prCFItem (CFTerm a) = prRegExp a
+-- if a category does not have a production of its own, we replace it by Ident
+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
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 811437f57..3a4706f27 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/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" $ 
-     checkTyp st typ ----- ++ 
-     ----- checkEquation st (m,c) d  ---- also if there's no def!
+   AbsFun (Yes typ0) md -> do
+    typ <- compAbsTyp [] typ0   -- to calculate let definitions
+    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 $