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".

src/GF/Compile/Export.hs

@@ -40,23 +40,20 @@ exportPGF opts fmt pgf =
       FmtProlog       -> multi "pl"  grammar2prolog 
       FmtProlog_Abs   -> multi "pl"  grammar2prolog_abs 
       FmtBNF          -> single "bnf"   bnfPrinter
-      FmtEBNF         -> single "ebnf"  (ebnfPrinter sisr)
+      FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
-      FmtNoLR         -> single "ebnf"  (nonLeftRecursivePrinter sisr)
-      FmtRegular      -> single "ebnf"   regularPrinter
       FmtFCFG         -> single "fcfg"  fcfgPrinter
-      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter sisr)
+      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter opts)
-      FmtSRGS_XML_NonRec -> single "grxml" srgsXmlNonRecursivePrinter
+      FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts)
-      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter sisr)
+      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter opts)
-      FmtSRGS_ABNF_NonRec -> single "gram" srgsAbnfNonRecursivePrinter
+      FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts)
-      FmtJSGF         -> single "jsgf"  (jsgfPrinter sisr)
+      FmtJSGF         -> single "jsgf"  (jsgfPrinter opts)
-      FmtGSL          -> single "gsl"   gslPrinter
+      FmtGSL          -> single "gsl"   (gslPrinter opts)
       FmtVoiceXML     -> single "vxml"  grammar2vxml
       FmtSLF          -> single "slf"  slfPrinter
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
  where
    name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
-   sisr = flag optSISR opts
    hsPrefix = flag optHaskellPrefix opts
 
    multi :: String -> (PGF -> String) -> [(FilePath,String)]

src/GF/Infra/Option.hs

@@ -4,7 +4,7 @@ module GF.Infra.Option
      Options, ModuleOptions,
      Flags(..), ModuleFlags(..),
      Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..), 
-     SISRFormat(..), Optimization(..),
+     SISRFormat(..), Optimization(..), CFGTransform(..),
      Dump(..), Printer(..), Recomp(..),
      -- * Option parsing 
      parseOptions, parseModuleOptions,
@@ -17,9 +17,9 @@ module GF.Infra.Option
      modifyFlags, modifyModuleFlags,
      helpMessage,
      -- * Checking specific options
-     flag, moduleFlag,
+     flag, moduleFlag, cfgTransform,
      -- * Setting specific options
-     setOptimization,
+     setOptimization, setCFGTransform,
      -- * Convenience methods for checking options    
      verbAtLeast, dump
     ) where
@@ -114,6 +114,15 @@ data SISRFormat =
 data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
   deriving (Show,Eq,Ord)
 
+data CFGTransform = CFGNoLR 
+                  | CFGRegular
+                  | CFGTopDownFilter 
+                  | CFGBottomUpFilter 
+                  | CFGStartCatOnly
+                  | CFGMergeIdentical
+                  | CFGRemoveCycles
+  deriving (Show,Eq,Ord)
+
 data Warning = WarnMissingLincat
   deriving (Show,Eq,Ord)
 
@@ -135,6 +144,7 @@ data ModuleFlags = ModuleFlags {
       optPreprocessors   :: [String],
       optEncoding        :: Encoding,
       optOptimizations   :: Set Optimization,
+      optCFGTransforms   :: Set CFGTransform,
       optLibraryPath     :: [FilePath],
       optStartCat        :: Maybe String,
       optSpeechLanguage  :: Maybe String,
@@ -280,6 +290,8 @@ defaultModuleFlags = ModuleFlags {
       optPreprocessors   = [],
       optEncoding        = ISO_8859_1,
       optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
+      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, 
+                                         CFGTopDownFilter, CFGMergeIdentical],
       optLibraryPath     = [],
       optStartCat        = Nothing,
       optSpeechLanguage  = Nothing,
@@ -347,6 +359,7 @@ moduleOptDescr =
                 "Select an optimization package. OPT = all | values | parametrize | none",
      Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
      Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
+     Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
      dumpOption "rebuild" DumpRebuild,
      dumpOption "extend" DumpExtend,
      dumpOption "rename" DumpRename,
@@ -379,6 +392,14 @@ moduleOptDescr =
 
        toggleOptimize x b = set $ setOptimization' x b
 
+       cfgTransform x = let (x', b) = case x of
+                                        'n':'o':'-':rest -> (rest, False)
+                                        _                -> (x, True)
+                         in case lookup x' cfgTransformNames of
+                              Just t  -> set $ setCFGTransform' t b
+                              Nothing -> fail $ "Unknown CFG transformation: " ++ x'
+                                                ++ " Known: " ++ show (map fst cfgTransformNames)
+
        dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
 
        set = return . ModuleOptions
@@ -491,6 +512,16 @@ optimizationPackages =
      ("none",        Set.fromList [OptStem,OptCSE,OptExpand]),
      ("noexpand",    Set.fromList [OptStem,OptCSE])]
 
+cfgTransformNames :: [(String, CFGTransform)]
+cfgTransformNames = 
+    [("nolr",         CFGNoLR),
+     ("regular",      CFGRegular),
+     ("topdown",      CFGTopDownFilter),
+     ("bottomup",     CFGBottomUpFilter),
+     ("startcatonly", CFGStartCatOnly),
+     ("merge",        CFGMergeIdentical),
+     ("removecycles", CFGRemoveCycles)]
+
 encodings :: [(String,Encoding)]
 encodings = 
     [("utf8",   UTF_8),
@@ -538,6 +569,9 @@ verbAtLeast opts v = flag optVerbosity opts >= v
 dump :: Options -> Dump -> Bool
 dump opts d = moduleFlag ((d `elem`) . optDump) opts
 
+cfgTransform :: Options -> CFGTransform -> Bool
+cfgTransform opts t = Set.member t (moduleFlag optCFGTransforms opts)
+
 -- 
 -- * Convenience functions for setting options
 --
@@ -546,8 +580,17 @@ setOptimization :: Optimization -> Bool -> Options
 setOptimization o b = modifyModuleFlags (setOptimization' o b)
 
 setOptimization' :: Optimization -> Bool -> ModuleFlags -> ModuleFlags
-setOptimization' o b f = f { optOptimizations = g (optOptimizations f)}
+setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)}
-  where g = if b then Set.insert o else Set.delete o
+
+setCFGTransform :: CFGTransform -> Bool -> Options
+setCFGTransform t b = modifyModuleFlags (setCFGTransform' t b)
+
+setCFGTransform' :: CFGTransform -> Bool -> ModuleFlags -> ModuleFlags
+setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) }
+
+toggle :: Ord a => a -> Bool -> Set a -> Set a
+toggle o True  = Set.insert o
+toggle o False = Set.delete o
 
 --
 -- * General utilities

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
 --

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 :: Options -> PGF -> CId -> String
-gslPrinter pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG pgf cnc
+gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width } 
 
 prGSL :: SRG -> Doc

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

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 :: Maybe SISRFormat -> PGF -> CId -> String
+ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
-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
-    where
-      preprocess =   mergeIdentical
-                   . makeRegular
-                   . topDownFilter
-                   . bottomUpFilter
-
-makeSRG :: (CFG -> CFG) -> PGF -> CId -> SRG
-makeSRG = mkSRG cfgToSRG
-    where
-      cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
 
 -- | Create a compact filtered non-left-recursive SRG. 
-makeNonLeftRecursiveSRG :: PGF -> CId -> SRG
+makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
-makeNonLeftRecursiveSRG  = makeSRG preprocess
+makeNonLeftRecursiveSRG opts = makeSRG opts'
     where
-      preprocess =   traceStats "After mergeIdentical"
+      opts' = setDefaultCFGTransform opts CFGNoLR True
-                   . mergeIdentical
+
-                   . traceStats "After removeLeftRecursion"
+makeSRG :: Options -> PGF -> CId -> SRG
-                   . removeLeftRecursion 
+makeSRG opts = mkSRG cfgToSRG preprocess
-                   . traceStats "After topDownFilter" 
+    where
-                   . topDownFilter
+      cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
-                   . traceStats "After bottomUpFilter"
+      preprocess =   maybeTransform opts CFGMergeIdentical mergeIdentical
-                   . bottomUpFilter
+                   . maybeTransform opts CFGNoLR removeLeftRecursion 
-                   . traceStats "After removeCycles"
+                   . maybeTransform opts CFGRegular makeRegular
-                   . removeCycles 
+                   . maybeTransform opts CFGTopDownFilter topDownFilter
-                   . traceStats "Inital CFG"
+                   . maybeTransform opts CFGBottomUpFilter bottomUpFilter
+                   . maybeTransform opts CFGRemoveCycles removeCycles 
+                   . maybeTransform opts CFGStartCatOnly purgeExternalCats
+
+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 :: Options -> SRG -> String
-prSRG sisr srg = prProductions $ map prRule $ ext ++ int
+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) = 

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 :: Options -> PGF -> CId -> String
-srgsAbnfNonRecursivePrinter pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG pgf cnc
+srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 showDoc = renderStyle (style { lineLength = width })
 

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 :: Options -> PGF -> CId -> String
-srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf cnc
+srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 
 prSrgsXml :: Maybe SISRFormat -> SRG -> String