Changed all SRG printer to take Options and StateGrammar arguments. This makes Custom a lot cleaner.

10 files changed, 84 insertions, 124 deletions

diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index 0e48c66d3..e1ee48610 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -27,6 +27,7 @@ import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..))
 import GF.Conversion.Types
 import GF.Infra.Ident (Ident)
+import GF.Infra.Option (Options)
 import GF.Compile.ShellState (StateGrammar)
 
 import GF.Speech.FiniteState
@@ -57,8 +58,9 @@ data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
 
 
 
-cfgToFA :: String -> StateGrammar -> DFA String
-cfgToFA start = minimize . compileAutomaton start . makeSimpleRegular
+cfgToFA :: Options -> StateGrammar -> DFA String
+cfgToFA opts s = minimize $ compileAutomaton start $ makeSimpleRegular s
+  where start = getStartCatCF opts s
 
 makeSimpleRegular :: StateGrammar -> CFRules
 makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules
@@ -145,12 +147,13 @@ make_fa c@(g,ns) q0 alpha q1 fa =
 -- * Compile a strongly regular grammar to a DFA with sub-automata
 --
 
-cfgToMFA :: String -> StateGrammar -> MFA String
-cfgToMFA start g = buildMFA start g
+cfgToMFA :: Options -> StateGrammar -> MFA String
+cfgToMFA opts s = buildMFA start s
+  where start = getStartCatCF opts s
 
 -- | Build a DFA by building and expanding an MFA
-cfgToFA' :: String -> StateGrammar -> DFA String
-cfgToFA' start = mfaToDFA . cfgToMFA start
+cfgToFA' :: Options -> StateGrammar -> DFA String
+cfgToFA' opts s = mfaToDFA $ cfgToMFA opts s
 
 buildMFA :: Cat_ -- ^ Start category
          -> StateGrammar -> MFA String
diff --git a/src/GF/Speech/PrFA.hs b/src/GF/Speech/PrFA.hs
index c1d5ca8ec..aeb43fde2 100644
--- a/src/GF/Speech/PrFA.hs
+++ b/src/GF/Speech/PrFA.hs
@@ -23,6 +23,7 @@ import GF.Conversion.Types
 import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..),symbol)
 import GF.Infra.Ident
+import GF.Infra.Option (Options)
 import GF.Infra.Print
 import GF.Speech.CFGToFiniteState
 import GF.Speech.FiniteState
@@ -36,23 +37,21 @@ import Data.Maybe (fromMaybe)
 
 
 
-faGraphvizPrinter :: Ident -- ^ Grammar name
-		   -> String -> StateGrammar -> String
-faGraphvizPrinter name start = 
-    prFAGraphviz . mapStates (const "") . cfgToFA start
+faGraphvizPrinter :: Options -> StateGrammar -> String
+faGraphvizPrinter opts s = 
+    prFAGraphviz $ mapStates (const "") $ cfgToFA opts s
 
 -- | Convert the grammar to a regular grammar and print it in BNF
-regularPrinter :: StateGrammar -> String
-regularPrinter = prCFRules . makeSimpleRegular
+regularPrinter :: Options -> StateGrammar -> String
+regularPrinter opts s = prCFRules $ makeSimpleRegular s
   where
   prCFRules :: CFRules -> String
   prCFRules g = unlines [ c ++ " ::= " ++ join " | " (map (showRhs . ruleRhs) rs) | (c,rs) <- g]
   join g = concat . intersperse g
   showRhs = unwords . map (symbol id show)
 
-faCPrinter :: Ident -- ^ Grammar name
-	   -> String -> StateGrammar -> String
-faCPrinter name start = fa2c . cfgToFA start
+faCPrinter :: Options -> StateGrammar -> String
+faCPrinter opts s = fa2c $ cfgToFA opts s
 
 fa2c :: DFA String -> String
 fa2c fa = undefined
\ No newline at end of file
diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index c60b9eae4..bec461c40 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -31,11 +31,8 @@ import GF.Compile.ShellState (StateGrammar)
 
 import Data.Char (toUpper,toLower)
 
-gslPrinter :: Ident   -- ^ Grammar name
-           -> String  -- ^ Start category
-	   -> Options -> StateGrammar -> String
-gslPrinter name start opts = 
-    prGSL . topDownFilter . makeSimpleSRG name start opts
+gslPrinter :: Options -> StateGrammar -> String
+gslPrinter opts s = prGSL $ topDownFilter $ makeSimpleSRG opts s
 
 prGSL :: SRG -> String
 prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs
index a94ae2ca2..d1d904dbb 100644
--- a/src/GF/Speech/PrJSGF.hs
+++ b/src/GF/Speech/PrJSGF.hs
@@ -38,13 +38,10 @@ import Text.PrettyPrint.HughesPJ
 import Debug.Trace
 
 
-jsgfPrinter :: Ident -- ^ Grammar name
-            -> String    -- ^ Start category
+jsgfPrinter :: Maybe SISRFormat
 	    -> Options 
-            -> Maybe SISRFormat
             -> StateGrammar -> String
-jsgfPrinter name start opts sisr = 
-    show . prJSGF sisr . makeSimpleSRG name start opts
+jsgfPrinter sisr opts s = show $ prJSGF sisr $ makeSimpleSRG opts s
 
 prJSGF :: Maybe SISRFormat -> SRG -> Doc
 prJSGF sisr srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/PrRegExp.hs b/src/GF/Speech/PrRegExp.hs
index 0f661edac..50156c42b 100644
--- a/src/GF/Speech/PrRegExp.hs
+++ b/src/GF/Speech/PrRegExp.hs
@@ -12,11 +12,11 @@ module GF.Speech.PrRegExp (regexpPrinter) where
 
 import GF.Conversion.Types
 import GF.Infra.Ident
+import GF.Infra.Option (Options)
 import GF.Speech.CFGToFiniteState
 import GF.Speech.RegExp
 import GF.Compile.ShellState (StateGrammar)
 
 
-regexpPrinter :: Ident -- ^ Grammar name
-	      -> String -> StateGrammar -> String
-regexpPrinter name start = prRE . dfa2re . cfgToFA start
+regexpPrinter :: Options -> StateGrammar -> String
+regexpPrinter opts s = prRE $ dfa2re $ cfgToFA opts s
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index 08af81549..a608917b6 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -26,6 +26,7 @@ import GF.Conversion.Types
 import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..),symbol)
 import GF.Infra.Ident
+import GF.Infra.Option (Options)
 import GF.Infra.Print
 import GF.Speech.CFGToFiniteState
 import GF.Speech.FiniteState
@@ -54,9 +55,9 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
 
 type SLF_FA = FA State (Maybe (MFALabel String)) ()
 
-mkFAs :: String -> StateGrammar -> (SLF_FA, [(String,SLF_FA)])
-mkFAs start s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
-  where MFA main subs = {- renameSubs $ -} cfgToMFA start s
+mkFAs :: Options -> StateGrammar -> (SLF_FA, [(String,SLF_FA)])
+mkFAs opts s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
+  where MFA main subs = {- renameSubs $ -} cfgToMFA opts s
 
 slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) ()
 slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing ()
@@ -76,9 +77,9 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs'
 -- * SLF graphviz printing (without sub-networks)
 --
 
-slfGraphvizPrinter :: Ident -> String -> StateGrammar -> String
-slfGraphvizPrinter name start 
-    = prFAGraphviz . gvFA . slfStyleFA . cfgToFA' start
+slfGraphvizPrinter :: Options -> StateGrammar -> String
+slfGraphvizPrinter opts s
+    = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts s
   where 
   gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
 
@@ -86,10 +87,9 @@ slfGraphvizPrinter name start
 -- * SLF graphviz printing (with sub-networks)
 --
 
-slfSubGraphvizPrinter :: Ident -- ^ Grammar name
-	           -> String -> StateGrammar -> String
-slfSubGraphvizPrinter name start s = Dot.prGraphviz g
-  where (main, subs) = mkFAs start s
+slfSubGraphvizPrinter :: Options -> StateGrammar -> String
+slfSubGraphvizPrinter opts s = Dot.prGraphviz g
+  where (main, subs) = mkFAs opts s
         g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] 
         ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
         m = gvSLFFA Nothing main
@@ -114,20 +114,19 @@ gvSLFFA n fa =
 -- * SLF printing (without sub-networks)
 --
 
-slfPrinter :: Ident -> String -> StateGrammar -> String
-slfPrinter name start
-    = prSLF . automatonToSLF mkSLFNode . slfStyleFA . cfgToFA' start
+slfPrinter :: Options -> StateGrammar -> String
+slfPrinter opts s 
+    = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts s
 
 --
 -- * SLF printing (with sub-networks)
 --
 
 -- | Make a network with subnetworks in SLF
-slfSubPrinter :: Ident -- ^ Grammar name
-	   -> String -> StateGrammar -> String
-slfSubPrinter name start s = prSLFs slfs
+slfSubPrinter :: Options -> StateGrammar -> String
+slfSubPrinter opts s = prSLFs slfs
   where 
-  (main,subs) = mkFAs start s
+  (main,subs) = mkFAs opts s
   slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main)
   faToSLF = automatonToSLF mfaNodeToSLFNode
 
diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs
index b68477f62..f3e08fc22 100644
--- a/src/GF/Speech/PrSRGS.hs
+++ b/src/GF/Speech/PrSRGS.hs
@@ -36,14 +36,11 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 
-srgsXmlPrinter :: Ident -- ^ Grammar name
-               -> String    -- ^ Start category
-	       -> Options 
-               -> Maybe SISRFormat 
+srgsXmlPrinter :: Maybe SISRFormat 
 	       -> Bool -- ^ Include probabilities
-	       -> StateGrammar -> String
-srgsXmlPrinter name start opts sisr probs = 
-    prSrgsXml sisr probs . makeSRG name start opts
+	       -> Options 
+               -> StateGrammar -> String
+srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSRG opts s
 
 prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String
 prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start,
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index e9081abab..cf74ba66e 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -42,7 +42,7 @@ import GF.Speech.FiniteState
 import GF.Speech.RegExp
 import GF.Infra.Option
 import GF.Probabilistic.Probabilistic (Probs)
-import GF.Compile.ShellState (StateGrammar, stateProbs)
+import GF.Compile.ShellState (StateGrammar, stateProbs, cncId)
 
 import Data.List
 import Data.Maybe (fromMaybe, maybeToList)
@@ -81,45 +81,37 @@ type CatNames = Map String String
 -- | Create a non-left-recursive SRG. 
 --   FIXME: the probabilities, names and profiles in the returned 
 --   grammar may be meaningless.
-makeSimpleSRG :: Ident     -- ^ Grammar name
-              -> String    -- ^ Start category
-	      -> Options   -- ^ Grammar options
+makeSimpleSRG :: Options   -- ^ Grammar options
 	      -> StateGrammar
 	      -> SRG
-makeSimpleSRG i origStart opts s =
-    makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
- where preprocess = removeLeftRecursion origStart . removeIdenticalRules 
-                    . removeEmptyCats . removeCycles
-       probs = stateProbs s
+makeSimpleSRG opts s =
+    makeSRG_ (removeLeftRecursion origStart . removeIdenticalRules 
+              . removeEmptyCats . removeCycles) opts s
+  where origStart = getStartCatCF opts s
 
 -- | Create a SRG preserving the names, profiles and probabilities of the 
 --   input grammar. The returned grammar may be left-recursive.
-makeSRG :: Ident     -- ^ Grammar name
-        -> String    -- ^ Start category
-	-> Options   -- ^ Grammar options
+makeSRG :: Options   -- ^ Grammar options
 	-> StateGrammar
 	-> SRG
-makeSRG i origStart opts s = 
-    makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
-  where preprocess = removeEmptyCats
-        probs = stateProbs s
-
-makeSRG_ :: Ident     -- ^ Grammar name
-         -> String    -- ^ Start category
-	 -> Options   -- ^ Grammar options
-	 -> Probs -- ^ Probabilities
-	 -> CFRules -- ^ A context-free grammar
+makeSRG = makeSRG_ removeEmptyCats
+
+makeSRG_ :: (CFRules -> CFRules)
+         -> Options   -- ^ Grammar options
+	 -> StateGrammar
 	 -> SRG
-makeSRG_ i origStart opts probs gr =
+makeSRG_ preprocess opts s =
       SRG { grammarName = name,
 	    startCat = lookupFM_ names origStart,
 	    origStartCat = origStart,
             grammarLanguage = l,
 	    rules = rs }
     where 
-    name = prIdent i
+    name = prIdent (cncId s)
+    origStart = getStartCatCF opts s
+    probs = stateProbs s
     l = fromMaybe "en_UK" (getOptVal opts speechLanguage)
-    (cats,cfgRules) = unzip gr
+    (cats,cfgRules) = unzip $ preprocess $ cfgToCFRules s
     names = mkCatNames name cats
     rs = map (cfgRulesToSRGRule names probs) cfgRules
 
diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs
index 923e90d7c..3a167eeef 100644
--- a/src/GF/Speech/TransformCFG.hs
+++ b/src/GF/Speech/TransformCFG.hs
@@ -24,6 +24,7 @@ module GF.Speech.TransformCFG {- (CFRule_, CFRules,
 			       removeEmptyCats, removeIdenticalRules) -} where
 
 import GF.Conversion.Types
+import GF.CF.PPrCF (prCFCat)
 import GF.Data.Utilities
 import GF.Formalism.CFG 
 import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, 
@@ -32,7 +33,7 @@ import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Infra.Print
 import GF.Speech.Relation
-import GF.Compile.ShellState (StateGrammar, stateCFG)
+import GF.Compile.ShellState (StateGrammar, stateCFG, startCatStateOpts)
 
 import Control.Monad
 import Control.Monad.State (State, get, put, evalState)
@@ -76,6 +77,13 @@ cfgToCFRules s =
           profileToTerm (Unify xs) = CFRes (last xs) -- FIXME: unify
           profileToTerm (Constant f) = maybe CFMeta (\x -> CFObj x []) (forestName f)
 
+getStartCat :: Options -> StateGrammar -> String
+getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr)
+
+getStartCatCF :: Options -> StateGrammar -> String
+getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s"
+
+
 -- | Remove productions which use categories which have no productions
 removeEmptyCats :: CFRules -> CFRules
 removeEmptyCats = fix removeEmptyCats'
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 992019aee..291b8405d 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -248,51 +248,22 @@ customGrammarPrinter =
   ,(strCI "cf",      \_ -> prCF . stateCF)
   ,(strCI "old",     \_ -> printGrammarOld . stateGrammarST)
   ,(strCI "srg",     \_ -> prSRG . stateCF)
-  ,(strCI "gsl",     \opts s -> let name = cncId s
-                                    start = getStartCatCF opts s
-                                 in gslPrinter name start opts s)
-  ,(strCI "jsgf",    \opts s -> let name = cncId s
-                                    start = getStartCatCF opts s
-                                 in jsgfPrinter name start opts Nothing s)
-  ,(strCI "jsgf_sisr_old", 
-                     \opts s -> let name = cncId s
-                                    start = getStartCatCF opts s
-                                 in jsgfPrinter name start opts (Just SISR.SISROld) s)
-  ,(strCI "srgs_xml", \opts s -> let name = cncId s
-                                     start = getStartCatCF opts s
-                                  in SRGS.srgsXmlPrinter name start opts Nothing False s)
-  ,(strCI "srgs_xml_prob", 
-              \opts s -> let name = cncId s
-                             start = getStartCatCF opts s
-                          in SRGS.srgsXmlPrinter name start opts Nothing True s)
-  ,(strCI "srgs_xml_sisr_old", 
-              \opts s -> let name = cncId s
-                             start = getStartCatCF opts s
-                          in SRGS.srgsXmlPrinter name start opts (Just SISR.SISROld) False s)
+  ,(strCI "gsl",     gslPrinter)
+  ,(strCI "jsgf",    jsgfPrinter Nothing)
+  ,(strCI "jsgf_sisr_old", jsgfPrinter (Just SISR.SISROld))
+  ,(strCI "srgs_xml", SRGS.srgsXmlPrinter Nothing False)
+  ,(strCI "srgs_xml_prob", SRGS.srgsXmlPrinter Nothing True)
+  ,(strCI "srgs_xml_sisr_old", SRGS.srgsXmlPrinter (Just SISR.SISROld) False)
   ,(strCI "vxml", \opts s -> let start = cfCat2Ident (startCatStateOpts opts s)
                               in grammar2vxml start s)
-  ,(strCI "slf",  \opts s -> let start = getStartCatCF opts s
-                                 name = cncId s
-                              in slfPrinter name start s)
-  ,(strCI "slf_graphviz", \opts s -> let start = getStartCatCF opts s
-                                         name = cncId s
-                                      in slfGraphvizPrinter name start s)
-  ,(strCI "slf_sub", \opts s -> let start = getStartCatCF opts s
-                                    name = cncId s
-                                 in slfSubPrinter name start s)
-  ,(strCI "slf_sub_graphviz", \opts s -> let start = getStartCatCF opts s
-                                             name = cncId s
-                                          in slfSubGraphvizPrinter name start s)
-  ,(strCI "fa_graphviz", \opts s -> let start = getStartCatCF opts s
-                                        name = cncId s
-                                     in faGraphvizPrinter name start s)
-  ,(strCI "fa_c", \opts s -> let start = getStartCatCF opts s
-                                 name = cncId s
-                              in faCPrinter name start s)
-  ,(strCI "regexp", \opts s -> let start = getStartCatCF opts s
-                                   name = cncId s
-                                in regexpPrinter name start s)
-  ,(strCI "regular", \_ -> regularPrinter)
+  ,(strCI "slf",  slfPrinter)
+  ,(strCI "slf_graphviz", slfGraphvizPrinter)
+  ,(strCI "slf_sub", slfSubPrinter)
+  ,(strCI "slf_sub_graphviz", slfSubGraphvizPrinter)
+  ,(strCI "fa_graphviz", faGraphvizPrinter)
+  ,(strCI "fa_c",  faCPrinter)
+  ,(strCI "regexp", regexpPrinter)
+  ,(strCI "regular", regularPrinter)
   ,(strCI "plbnf",   \_ -> prLBNF True)
   ,(strCI "lbnf",    \_ -> prLBNF False)
   ,(strCI "bnf",     \_ -> prBNF False)
@@ -345,9 +316,6 @@ customGrammarPrinter =
 --  ,(strCI "cfg-old",  PrtOld.prt . CnvOld.cfg . statePInfoOld)
   ] 
   where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s)
-        getStartCat,getStartCatCF :: Options -> StateGrammar -> String
-        getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr)
-        getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s"
 
 customMultiGrammarPrinter = 
   customData "Printers for multiple grammars, selected by option -printer=x" $