Got SRGS ABNF generation to compile.

3 files changed, 27 insertions, 46 deletions

diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs
index 2aac9ad13..739079c9c 100644
--- a/src/GF/Compile/Export.hs
+++ b/src/GF/Compile/Export.hs
@@ -10,6 +10,7 @@ import GF.Compile.GFCCtoJS
 import GF.Infra.Option
 import GF.Speech.CFG
 import GF.Speech.PGFToCFG
+import GF.Speech.SRGS_ABNF
 import GF.Speech.SRGS_XML
 import GF.Speech.JSGF
 import GF.Speech.GSL
@@ -38,6 +39,8 @@ exportPGF opts fmt pgf =
       FmtBNF          -> single "bnf"   bnfPrinter
       FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter sisr)
       FmtSRGS_XML_NonRec -> single "grxml" srgsXmlNonRecursivePrinter
+      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter sisr)
+      FmtSRGS_ABNF_NonRec -> single "gram" srgsXmlNonRecursivePrinter
       FmtJSGF         -> single "jsgf"  (jsgfPrinter sisr)
       FmtGSL          -> single "gsl"   gslPrinter
       FmtVoiceXML     -> single "vxml"  grammar2vxml
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index a861d889d..f9065dae9 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -50,8 +50,7 @@ data SRG = SRG { srgName :: String    -- ^ grammar name
 	       }
 	 deriving (Eq,Show)
 
-data SRGRule = SRGRule Cat [SRGAlt] -- ^ SRG category name, original category name
-	                                      --   and productions
+data SRGRule = SRGRule Cat [SRGAlt]
 	     deriving (Eq,Show)
 
 -- | maybe a probability, a rule name and an EBNF right-hand side
diff --git a/src/GF/Speech/SRGS_ABNF.hs b/src/GF/Speech/SRGS_ABNF.hs
index abb84c5dc..28f4b5684 100644
--- a/src/GF/Speech/SRGS_ABNF.hs
+++ b/src/GF/Speech/SRGS_ABNF.hs
@@ -17,21 +17,15 @@
 -- FIXME: convert to UTF-8
 -----------------------------------------------------------------------------
 
-module GF.Speech.PrSRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
+module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
 
-import GF.Conversion.Types
 import GF.Data.Utilities
-import GF.Formalism.CFG
-import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), filterCats)
-import GF.Infra.Ident
-import GF.Infra.Print
 import GF.Infra.Option
-import GF.Probabilistic.Probabilistic (Probs)
-import GF.Speech.SISR
+import GF.Speech.CFG
+import GF.Speech.SISR as SISR
 import GF.Speech.SRG
 import GF.Speech.RegExp
-import GF.Compile.ShellState (StateGrammar)
-import GF.Today
+import PGF (PGF, CId)
 
 import Data.Char
 import Data.List
@@ -43,49 +37,33 @@ width :: Int
 width = 75
 
 srgsAbnfPrinter :: Maybe SISRFormat
-                -> Bool -- ^ Include probabilities
-	        -> Options 
-                -> StateGrammar -> String
-srgsAbnfPrinter sisr probs opts s = showDoc $ prABNF sisr probs $ makeSimpleSRG opts s
+	        -> PGF -> CId -> String
+srgsAbnfPrinter sisr pgf cnc = showDoc $ prABNF sisr $ makeSimpleSRG pgf cnc
 
-srgsAbnfNonRecursivePrinter :: Options -> StateGrammar -> String
-srgsAbnfNonRecursivePrinter opts s = showDoc $ prABNF Nothing False $ makeNonRecursiveSRG opts s
+srgsAbnfNonRecursivePrinter :: PGF -> CId -> String
+srgsAbnfNonRecursivePrinter pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG pgf cnc
 
 showDoc = renderStyle (style { lineLength = width })
 
-prABNF :: Maybe SISRFormat -> Bool -> SRG -> Doc
-prABNF sisr probs srg@(SRG{grammarName=name,grammarLanguage=ml,
-                     startCat=start,origStartCat=origStart,rules=rs})
-    = header $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs)
+prABNF :: Maybe SISRFormat -> SRG -> Doc
+prABNF sisr srg
+    = header $++$ foldr ($++$) empty (map prRule (srgRules srg))
     where
     header = text "#ABNF 1.0 UTF-8;" $$
-             meta "description" 
-               ("Speech recognition grammar for " ++ name
-                ++ ". " ++ "Original start category: " ++ origStart) $$
-             meta "generator" ("Grammatical Framework " ++ version) $$
+             meta "description" ("Speech recognition grammar for " ++ srgName srg) $$
+             meta "generator" "Grammatical Framework" $$
              language $$ tagFormat $$ mainCat
-    language = maybe empty (\l -> text "language" <+> text l <> char ';') ml
+    language = maybe empty (\l -> text "language" <+> text l <> char ';') (srgLanguage srg)
     tagFormat | isJust sisr = text "tag-format" <+> text "<semantics/1.0>" <> char ';'
               | otherwise = empty
-    mainCat = case cfgCatToGFCat origStart of
-                Just c  -> text "root" <+> prCat (catFormId c) <> char ';'
-                Nothing -> empty
-    prRule (SRGRule cat origCat rhs) = 
-	comment origCat $$
-        rule False cat (map prAlt rhs)
-    -- FIXME: use the probability
+    mainCat = text "root" <+> prCat (srgStartCat srg) <> char ';'
+    prRule (SRGRule cat alts) = rule (isExternalCat srg cat) cat (map prAlt alts)
     prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag]
       where initTag = tag sisr (profileInitSISR n)
             finalTag = tag sisr (profileFinalSISR n)
             p = if isEmpty initTag && isEmpty finalTag then id else parens
 
-    topCatRules = [rule True (catFormId tc) (map (it tc) cs) | (tc,cs) <- srgTopCats srg]
-        where it i c = prCat c <+> tag sisr (topCatSISR c)
-
-catFormId :: String -> String
-catFormId = (++ "_cat")
-
-prCat :: SRGCat -> Doc
+prCat :: Cat -> Doc
 prCat c = char '$' <> text c
 
 prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
@@ -102,10 +80,11 @@ prItem sisr t = f 0
     f _ (RESymbol s)  = prSymbol sisr t s
 
 
-prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> Doc
-prSymbol sisr cn (Cat n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
-prSymbol _ cn (Tok t) | all isPunct (prt t) = empty  -- removes punctuation
-                      | otherwise = text (prt t) -- FIXME: quote if there is whitespace or odd chars
+prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
+prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
+prSymbol _ cn (Terminal t) 
+    | all isPunct t = empty  -- removes punctuation
+    | otherwise = text t -- FIXME: quote if there is whitespace or odd chars
 
 tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
 tag Nothing _ = empty
@@ -126,7 +105,7 @@ comment s = text "//" <+> text s
 alts :: [Doc] -> Doc
 alts = fsep . prepunctuate (text "| ")
 
-rule :: Bool -> SRGCat -> [Doc] -> Doc
+rule :: Bool -> Cat -> [Doc] -> Doc
 rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';'
   where p = if pub then text "public" else empty