From 8fe2a1cc59728e8bb345fe51cd94bb5bcba1883c Mon Sep 17 00:00:00 2001
From: bjorn <bjorn@bringert.net>
Date: Fri, 26 Sep 2008 12:57:20 +0000
Subject: [PATCH] Added semantic interpretation tag printing to the *bnf
 grammar printers.

---
 src/GF/Compile/Export.hs |  4 ++--
 src/GF/Speech/CFG.hs     | 12 ++++++++++++
 src/GF/Speech/RegExp.hs  |  1 +
 src/GF/Speech/SRG.hs     | 30 +++++++++++++++++++++---------
 4 files changed, 36 insertions(+), 11 deletions(-)

diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs
index 3debe60e0..23817b70f 100644
--- a/src/GF/Compile/Export.hs
+++ b/src/GF/Compile/Export.hs
@@ -38,8 +38,8 @@ exportPGF opts fmt pgf =
       FmtProlog       -> multi "pl"  grammar2prolog 
       FmtProlog_Abs   -> multi "pl"  grammar2prolog_abs 
       FmtBNF          -> single "bnf"   bnfPrinter
-      FmtEBNF         -> single "ebnf"  ebnfPrinter
-      FmtNoLR         -> single "ebnf"  nonLeftRecursivePrinter
+      FmtEBNF         -> single "ebnf"  (ebnfPrinter sisr)
+      FmtNoLR         -> single "ebnf"  (nonLeftRecursivePrinter sisr)
       FmtRegular      -> single "ebnf"   regularPrinter
       FmtFCFG         -> single "fcfg"  fcfgPrinter
       FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter sisr)
diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs
index 8e6c520d6..3e4db14d4 100644
--- a/src/GF/Speech/CFG.hs
+++ b/src/GF/Speech/CFG.hs
@@ -285,6 +285,18 @@ prProductions prods =
       maxLHSWidth = maximum $ 0:(map (length . fst) prods)
       rpad n s = s ++ replicate (n - length s) ' '
 
+prCFTerm :: CFTerm -> String
+prCFTerm = pr 0
+  where
+    pr p (CFObj f args) = paren p (prCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
+    pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
+    pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
+    pr _ (CFRes i) = "$" ++ show i
+    pr _ (CFVar i) = "x" ++ show i
+    pr _ (CFMeta c) = "?" ++ prCId c
+    paren 0 x = x
+    paren 1 x = "(" ++ x ++ ")"
+
 --
 -- * CFRule Utilities
 --
diff --git a/src/GF/Speech/RegExp.hs b/src/GF/Speech/RegExp.hs
index 902569629..2592b3d57 100644
--- a/src/GF/Speech/RegExp.hs
+++ b/src/GF/Speech/RegExp.hs
@@ -133,6 +133,7 @@ symbolsRE (RESymbol x) = [x]
 prRE :: (a -> String) -> RE a -> String
 prRE = prRE' 0
 
+prRE' :: Int -> (a -> String) -> RE a -> String
 prRE' _ _ (REUnion []) = "<NULL>"
 prRE' n f (REUnion xs) = p n 1 (concat (intersperse " | " (map (prRE' 1 f) xs)))
 prRE' n f (REConcat xs) = p n 2 (unwords (map (prRE' 2 f) xs))
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index 359672d63..107d81e10 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -68,14 +68,14 @@ type SRGSymbol = Symbol SRGNT Token
 type SRGNT = (Cat, Int)
 
 
-ebnfPrinter :: PGF -> CId -> String
-ebnfPrinter pgf cnc = prSRG $ makeSRG id pgf cnc
+ebnfPrinter :: Maybe SISRFormat -> PGF -> CId -> String
+ebnfPrinter sisr pgf cnc = prSRG sisr $ makeSRG id pgf cnc
 
-nonLeftRecursivePrinter :: PGF -> CId -> String
-nonLeftRecursivePrinter pgf cnc = prSRG $ makeSRG removeLeftRecursion pgf cnc
+nonLeftRecursivePrinter :: Maybe SISRFormat -> PGF -> CId -> String
+nonLeftRecursivePrinter sisr pgf cnc = prSRG sisr $ makeSRG removeLeftRecursion pgf cnc
 
 regularPrinter :: PGF -> CId -> String
-regularPrinter pgf cnc = prSRG $ makeSRG makeRegular pgf cnc
+regularPrinter pgf cnc = prSRG Nothing $ makeSRG makeRegular pgf cnc
 
 makeSRG :: (CFG -> CFG) -> PGF -> CId -> SRG
 makeSRG = mkSRG cfgToSRG
@@ -182,12 +182,24 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
 -- * Utilities for building and printing SRGs
 --
 
-prSRG :: SRG -> String
-prSRG srg = prProductions $ map prRule $ ext ++ int
+prSRG :: Maybe SISRFormat -> SRG -> String
+prSRG sisr srg = prProductions $ map prRule $ ext ++ int
     where 
       (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
-      prRule (SRGRule c alts) = (c,unwords (intersperse "|" (map prAlt alts)))
-      prAlt (SRGAlt _ _ rhs) = prRE prSym rhs
+      prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
+      prAlt (SRGAlt _ t rhs) = 
+          -- FIXME: hack: we high-jack the --sisr flag to add 
+          -- a simple lambda calculus format for semantic interpretation
+          -- Maybe the --sisr flag should be renamed.
+          case sisr of
+            Just _  -> 
+                -- copy tags to each part of a top-level union,
+                -- to get simpler output
+                case rhs of
+                  REUnion xs -> map prOneAlt xs
+                  _          -> [prOneAlt rhs]
+                where prOneAlt a = prRE prSym a ++ " { " ++ prCFTerm t ++ " }"
+            Nothing -> [prRE prSym rhs]
       prSym = symbol fst (\t -> "\""++ t ++"\"")
 
 lookupFM_ :: (Ord key, Show key) => Map key elt -> key -> elt