diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs index f24e840c3..8fb4cbed8 100644 --- 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)] diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index e9b70ccf7..8e8d44aff 100644 --- 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 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 :: 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) = 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