summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/Compile/Export.hs17
-rw-r--r--src/GF/Infra/Option.hs53
-rw-r--r--src/GF/Speech/CFG.hs4
-rw-r--r--src/GF/Speech/GSL.hs5
-rw-r--r--src/GF/Speech/JSGF.hs6
-rw-r--r--src/GF/Speech/SRG.hs66
-rw-r--r--src/GF/Speech/SRGS_ABNF.hs9
-rw-r--r--src/GF/Speech/SRGS_XML.hs9
8 files changed, 103 insertions, 66 deletions
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 :: 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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:51:17 +0000