revising tex

2 files changed, 62 insertions, 8 deletions

diff --git a/src/GF/CF/PrLBNF.hs b/src/GF/CF/PrLBNF.hs
index 701674a52..fe06cbf9e 100644
--- a/src/GF/CF/PrLBNF.hs
+++ b/src/GF/CF/PrLBNF.hs
@@ -5,22 +5,32 @@ import CFIdent
 import AbsGFC
 import Ident
 import PrGrammar
+import ShellState
+import GFC
+import Look
 
 import Operations
+import Modules
+
 import Char
+import List (nub)
 
 -- Printing CF grammars generated from GF as LBNF grammar for BNFC.
--- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003
+-- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 -- 27/9/2004
 -- With primitive error messaging, by rules and rule tails commented out
 
-prLBNF :: CF -> String
-prLBNF cf = unlines $ (map (prCFRule cs)) $ rulesOfCF cf --- no literal recogn function
+prLBNF :: Bool -> StateGrammar -> String
+prLBNF new gr = unlines $ pragmas ++ (map (prCFRule cs) rules)
   where    
-    cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rulesOfCF cf]
+    cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rules]
+    cf = stateCF gr
+    (pragmas,rules) = if new  -- tries to treat precedence levels
+                         then mkLBNF (stateGrammarST gr) $ rulesOfCF cf
+                         else ([],rulesOfCF cf) -- "normal" behaviour
 
 -- a hack to hide the LBNF details
-prBNF :: CF -> String
-prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF
+prBNF :: Bool -> StateGrammar -> String
+prBNF b = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF b
   where
     unLBNF r = case r of
       "---":ts -> ts
@@ -28,6 +38,48 @@ prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF
       c:ts -> c : unLBNF ts
       _ -> r
 
+--- awful low level code without abstraction over label names etc
+mkLBNF :: CanonGrammar -> [CFRule] -> ([String],[CFRule])
+mkLBNF gr rules = (coercions, nub $ concatMap mkRule rules) where
+  coercions = ["coercions" +++ prt_ c +++ show n +++ ";"  | 
+    (_,ModMod m) <- modules gr,
+    (c,CncCat (RecType ls) _ _) <- tree2list $ jments m,
+    Lbg (L (IC "p")) (TInts n) <- ls
+    ]
+  precedences = [(f,(prec,assoc))  | 
+    (_,ModMod m) <- modules gr,
+    (f,CncFun _ _ (R lin) _) <- tree2list $ jments m,
+    (Just prec, Just assoc) <- [(
+       lookup "p" [(lab,p) | Ass (L (IC lab)) (EInt p) <- lin],
+       lookup "a" [(lab,a) | Ass (L (IC lab)) (Con (CIQ _ (IC a)) []) <- lin]
+       )]
+    ]
+  precfuns = map fst precedences
+  mkRule r@(fun@(CFFun (t, p)),(cat,its)) = case t of
+    AC (CIQ _ c) -> case lookup c precedences of
+      Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
+      _ -> return r
+    AD (CIQ _ c) -> case lookup c precedences of
+      Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
+      _ -> return r
+    _ -> return r
+  mkIts cat prec assoc i its = case its of
+    CFTerm (RegAlts ["("]):n@(CFNonterm k):CFTerm (RegAlts [")"]):rest | k==cat -> 
+      mkIts cat prec assoc i $ n:rest  -- remove variants with parentheses 
+    CFNonterm k:rest | k==cat -> 
+      CFNonterm (mkNonterm prec assoc i k) : mkIts cat prec assoc (i+1) rest
+    it:rest -> it:mkIts cat prec assoc i rest
+    [] -> []
+
+  mkCat prec (CFCat ((CIQ m (IC c)),l)) = CFCat ((CIQ m (IC (c ++ show prec ++ "+"))),l)
+  mkNonterm prec assoc i cat = mkCat prec' cat 
+    where 
+      prec' = case (assoc,i) of
+        ("PL",0) -> prec
+        ("PR",0) -> prec + 1
+        ("PR",_) -> prec
+        _        -> prec + 1
+
 catId ((CFCat ((CIQ _ c),l))) = c
 
 prCFRule :: [Ident] -> CFRule -> String
@@ -50,6 +102,7 @@ prId b i = case i of
      IC "#Var" -> "Ident"
      IC "Var"  -> "Ident"
      IC "id_"  -> "_"
+     IC s@(c:_) | last s == '+' -> init s  -- hack to save precedence information
      IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else ""
      _ -> prErr b $ prt i
 
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 643c16661..9119b8f36 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -194,8 +194,9 @@ customGrammarPrinter =
   ,(strCI "gsl",     \s -> let opts = stateOptions s
                                name = cncId s
                             in gslPrinter name opts $ Cnv.cfg $ statePInfo s)
-  ,(strCI "lbnf",    prLBNF . stateCF)
-  ,(strCI "bnf",     prBNF . stateCF)
+  ,(strCI "plbnf",   prLBNF True)
+  ,(strCI "lbnf",    prLBNF False)
+  ,(strCI "bnf",     prBNF False)
   ,(strCI "haskell", grammar2haskell . stateGrammarST)
   ,(strCI "morpho",  prMorpho . stateMorpho)
   ,(strCI "fullform",prFullForm . stateMorpho)