Added --cfg option for specifying which CFG transformations to use. Added startcatonly CFG trasnformation. Removed output formats that are now easily done with --cfg: "regular", "nolr".

6 files changed, 48 insertions, 51 deletions

diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs
index 3e4db14d4..52db2827a 100644
--- a/src/GF/Speech/CFG.hs
+++ b/src/GF/Speech/CFG.hs
@@ -101,6 +101,10 @@ mergeIdentical g = onRules (map subst) g
     subst (CFRule c r n) = CFRule (substCat c) (map (mapSymbol substCat id) r) n
     substCat c = Map.findWithDefault (error $ "mergeIdentical: " ++ c) c m
 
+-- | Keeps only the start category as an external category.
+purgeExternalCats :: CFG -> CFG
+purgeExternalCats cfg = cfg { cfgExternalCats = Set.singleton (cfgStartCat cfg) }
+
 --
 -- * Removing left recursion
 --
diff --git a/src/GF/Speech/GSL.hs b/src/GF/Speech/GSL.hs
index 5acf2476e..8f26ea64c 100644
--- a/src/GF/Speech/GSL.hs
+++ b/src/GF/Speech/GSL.hs
@@ -12,6 +12,7 @@ import GF.Data.Utilities
 import GF.Speech.CFG
 import GF.Speech.SRG
 import GF.Speech.RegExp
+import GF.Infra.Option
 import GF.Infra.Ident
 import PGF.CId
 import PGF.Data
@@ -23,8 +24,8 @@ import Text.PrettyPrint.HughesPJ
 width :: Int
 width = 75
 
-gslPrinter :: PGF -> CId -> String
-gslPrinter pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG pgf cnc
+gslPrinter :: Options -> PGF -> CId -> String
+gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width } 
 
 prGSL :: SRG -> Doc
diff --git a/src/GF/Speech/JSGF.hs b/src/GF/Speech/JSGF.hs
index 171d859a4..2cfeea5f5 100644
--- a/src/GF/Speech/JSGF.hs
+++ b/src/GF/Speech/JSGF.hs
@@ -13,6 +13,7 @@
 module GF.Speech.JSGF (jsgfPrinter) where
 
 import GF.Data.Utilities
+import GF.Infra.Option
 import GF.Speech.CFG
 import GF.Speech.RegExp
 import GF.Speech.SISR
@@ -29,11 +30,12 @@ import Debug.Trace
 width :: Int
 width = 75
 
-jsgfPrinter :: Maybe SISRFormat
+jsgfPrinter :: Options
 	    -> PGF 
             -> CId -> String
-jsgfPrinter sisr pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG pgf cnc
+jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width }
+        sisr = flag optSISR opts
 
 prJSGF :: Maybe SISRFormat -> SRG -> Doc
 prJSGF sisr srg
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index b51808d9f..622ba4ca3 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -11,8 +11,6 @@
 module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
                      , SRGNT, CFTerm
                      , ebnfPrinter
-                     , nonLeftRecursivePrinter
-                     , regularPrinter
                      , makeNonLeftRecursiveSRG
                      , makeNonRecursiveSRG
                      , getSpeechLanguage
@@ -23,6 +21,7 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
 import GF.Data.Operations
 import GF.Data.Utilities
 import GF.Infra.Ident
+import GF.Infra.Option
 import GF.Infra.PrintClass
 import GF.Speech.CFG
 import GF.Speech.PGFToCFG
@@ -67,45 +66,32 @@ type SRGSymbol = Symbol SRGNT Token
 -- | An SRG non-terminal. Category name and its number in the profile.
 type SRGNT = (Cat, Int)
 
+ebnfPrinter :: Options -> PGF -> CId -> String
+ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
 
-ebnfPrinter :: Maybe SISRFormat -> PGF -> CId -> String
-ebnfPrinter sisr pgf cnc = prSRG sisr $ makeSRG preprocess pgf cnc
-    where
-      preprocess =   mergeIdentical
-                   . topDownFilter
-                   . bottomUpFilter
-
-nonLeftRecursivePrinter :: Maybe SISRFormat -> PGF -> CId -> String
-nonLeftRecursivePrinter sisr pgf cnc = prSRG sisr $ makeNonLeftRecursiveSRG pgf cnc
-
-regularPrinter :: PGF -> CId -> String
-regularPrinter pgf cnc = prSRG Nothing $ makeSRG preprocess pgf cnc
+-- | Create a compact filtered non-left-recursive SRG. 
+makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
+makeNonLeftRecursiveSRG opts = makeSRG opts'
     where
-      preprocess =   mergeIdentical
-                   . makeRegular
-                   . topDownFilter
-                   . bottomUpFilter
+      opts' = setDefaultCFGTransform opts CFGNoLR True
 
-makeSRG :: (CFG -> CFG) -> PGF -> CId -> SRG
-makeSRG = mkSRG cfgToSRG
+makeSRG :: Options -> PGF -> CId -> SRG
+makeSRG opts = mkSRG cfgToSRG preprocess
     where
       cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
+      preprocess =   maybeTransform opts CFGMergeIdentical mergeIdentical
+                   . maybeTransform opts CFGNoLR removeLeftRecursion 
+                   . maybeTransform opts CFGRegular makeRegular
+                   . maybeTransform opts CFGTopDownFilter topDownFilter
+                   . maybeTransform opts CFGBottomUpFilter bottomUpFilter
+                   . maybeTransform opts CFGRemoveCycles removeCycles 
+                   . maybeTransform opts CFGStartCatOnly purgeExternalCats
 
--- | Create a compact filtered non-left-recursive SRG. 
-makeNonLeftRecursiveSRG :: PGF -> CId -> SRG
-makeNonLeftRecursiveSRG  = makeSRG preprocess
-    where
-      preprocess =   traceStats "After mergeIdentical"
-                   . mergeIdentical
-                   . traceStats "After removeLeftRecursion"
-                   . removeLeftRecursion 
-                   . traceStats "After topDownFilter" 
-                   . topDownFilter
-                   . traceStats "After bottomUpFilter"
-                   . bottomUpFilter
-                   . traceStats "After removeCycles"
-                   . removeCycles 
-                   . traceStats "Inital CFG"
+setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
+setDefaultCFGTransform opts t b = setCFGTransform t b `addOptions` opts
+
+maybeTransform :: Options -> CFGTransform -> (CFG -> CFG) -> (CFG -> CFG)
+maybeTransform opts t f = if cfgTransform opts t then f else id
 
 traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g
 
@@ -113,10 +99,11 @@ stats g = "Categories: " ++ show (countCats g)
           ++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
           ++ ", Rules: " ++ show (countRules g)
 
-makeNonRecursiveSRG :: PGF
+makeNonRecursiveSRG :: Options 
+                    -> PGF
                     -> CId -- ^ Concrete syntax name.
                     -> SRG
-makeNonRecursiveSRG = mkSRG cfgToSRG id
+makeNonRecursiveSRG opts = mkSRG cfgToSRG id
     where
       cfgToSRG cfg = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas]
           where
@@ -192,9 +179,10 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
 -- * Utilities for building and printing SRGs
 --
 
-prSRG :: Maybe SISRFormat -> SRG -> String
-prSRG sisr srg = prProductions $ map prRule $ ext ++ int
+prSRG :: Options -> SRG -> String
+prSRG opts srg = prProductions $ map prRule $ ext ++ int
     where 
+      sisr = flag optSISR opts
       (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
       prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
       prAlt (SRGAlt _ t rhs) = 
diff --git a/src/GF/Speech/SRGS_ABNF.hs b/src/GF/Speech/SRGS_ABNF.hs
index 544628a25..2df1316a8 100644
--- a/src/GF/Speech/SRGS_ABNF.hs
+++ b/src/GF/Speech/SRGS_ABNF.hs
@@ -36,12 +36,13 @@ import Debug.Trace
 width :: Int
 width = 75
 
-srgsAbnfPrinter :: Maybe SISRFormat
+srgsAbnfPrinter :: Options
 	        -> PGF -> CId -> String
-srgsAbnfPrinter sisr pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG pgf cnc
+srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
+    where sisr = flag optSISR opts
 
-srgsAbnfNonRecursivePrinter :: PGF -> CId -> String
-srgsAbnfNonRecursivePrinter pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG pgf cnc
+srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
+srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 showDoc = renderStyle (style { lineLength = width })
 
diff --git a/src/GF/Speech/SRGS_XML.hs b/src/GF/Speech/SRGS_XML.hs
index 5846e3157..1f94de66d 100644
--- a/src/GF/Speech/SRGS_XML.hs
+++ b/src/GF/Speech/SRGS_XML.hs
@@ -21,12 +21,13 @@ import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
 
-srgsXmlPrinter :: Maybe SISRFormat 
+srgsXmlPrinter :: Options
                -> PGF -> CId -> String
-srgsXmlPrinter sisr pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG pgf cnc
+srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc
+    where sisr = flag optSISR opts
 
-srgsXmlNonRecursivePrinter :: PGF -> CId -> String
-srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf cnc
+srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
+srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 
 prSrgsXml :: Maybe SISRFormat -> SRG -> String