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

2008-09-30 11:52:11 +00:00
parent 794fbd4a41
commit 446aa1b5db
8 changed files with 106 additions and 69 deletions
--- a/src/GF/Compile/Export.hs
+++ b/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)
-      FmtNoLR         -> single "ebnf"  (nonLeftRecursivePrinter sisr)
-      FmtRegular      -> single "ebnf"   regularPrinter
+      FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
      FmtFCFG         -> single "fcfg"  fcfgPrinter
-      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter sisr)
-      FmtSRGS_XML_NonRec -> single "grxml" srgsXmlNonRecursivePrinter
-      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter sisr)
-      FmtSRGS_ABNF_NonRec -> single "gram" srgsAbnfNonRecursivePrinter
-      FmtJSGF         -> single "jsgf"  (jsgfPrinter sisr)
-      FmtGSL          -> single "gsl"   gslPrinter
+      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter opts)
+      FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts)
+      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter opts)
+      FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts)
+      FmtJSGF         -> single "jsgf"  (jsgfPrinter opts)
+      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)]
--- a/src/GF/Infra/Option.hs
+++ b/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)}
-  where g = if b then Set.insert o else Set.delete o
+setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)}
+
+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
--- 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
 --
--- 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
--- 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
--- 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 :: 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
-    where
-      preprocess =   mergeIdentical
-                   . makeRegular
-                   . topDownFilter
-                   . bottomUpFilter
-
-makeSRG :: (CFG -> CFG) -> PGF -> CId -> SRG
-makeSRG = mkSRG cfgToSRG
-    where
-      cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
+ebnfPrinter :: Options -> PGF -> CId -> String
+ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc

 -- | Create a compact filtered non-left-recursive SRG. 
-makeNonLeftRecursiveSRG :: PGF -> CId -> SRG
-makeNonLeftRecursiveSRG  = makeSRG preprocess
+makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
+makeNonLeftRecursiveSRG opts = makeSRG opts'
    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"
+      opts' = setDefaultCFGTransform opts CFGNoLR True
+
+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
+
+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) = 
--- 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 })

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