printing to LBNF with profiles

1 files changed, 28 insertions, 15 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