From 028f2e108ec2357ea9832550d82aa4f3550fc88f Mon Sep 17 00:00:00 2001 From: bringert Date: Fri, 5 Jan 2007 15:38:47 +0000 Subject: [PATCH] Changed all SRG printer to take Options and StateGrammar arguments. This makes Custom a lot cleaner. --- src/GF/Speech/CFGToFiniteState.hs | 15 ++++---- src/GF/Speech/PrFA.hs | 17 +++++---- src/GF/Speech/PrGSL.hs | 7 ++-- src/GF/Speech/PrJSGF.hs | 7 ++-- src/GF/Speech/PrRegExp.hs | 6 ++-- src/GF/Speech/PrSLF.hs | 33 +++++++++-------- src/GF/Speech/PrSRGS.hs | 11 +++--- src/GF/Speech/SRG.hs | 40 +++++++++------------ src/GF/Speech/TransformCFG.hs | 10 +++++- src/GF/UseGrammar/Custom.hs | 60 ++++++++----------------------- 10 files changed, 83 insertions(+), 123 deletions(-) diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index 0e48c66d3..e1ee48610 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -27,6 +27,7 @@ import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) import GF.Conversion.Types import GF.Infra.Ident (Ident) +import GF.Infra.Option (Options) import GF.Compile.ShellState (StateGrammar) import GF.Speech.FiniteState @@ -57,8 +58,9 @@ data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))] -cfgToFA :: String -> StateGrammar -> DFA String -cfgToFA start = minimize . compileAutomaton start . makeSimpleRegular +cfgToFA :: Options -> StateGrammar -> DFA String +cfgToFA opts s = minimize $ compileAutomaton start $ makeSimpleRegular s + where start = getStartCatCF opts s makeSimpleRegular :: StateGrammar -> CFRules makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules @@ -145,12 +147,13 @@ make_fa c@(g,ns) q0 alpha q1 fa = -- * Compile a strongly regular grammar to a DFA with sub-automata -- -cfgToMFA :: String -> StateGrammar -> MFA String -cfgToMFA start g = buildMFA start g +cfgToMFA :: Options -> StateGrammar -> MFA String +cfgToMFA opts s = buildMFA start s + where start = getStartCatCF opts s -- | Build a DFA by building and expanding an MFA -cfgToFA' :: String -> StateGrammar -> DFA String -cfgToFA' start = mfaToDFA . cfgToMFA start +cfgToFA' :: Options -> StateGrammar -> DFA String +cfgToFA' opts s = mfaToDFA $ cfgToMFA opts s buildMFA :: Cat_ -- ^ Start category -> StateGrammar -> MFA String diff --git a/src/GF/Speech/PrFA.hs b/src/GF/Speech/PrFA.hs index c1d5ca8ec..aeb43fde2 100644 --- a/src/GF/Speech/PrFA.hs +++ b/src/GF/Speech/PrFA.hs @@ -23,6 +23,7 @@ import GF.Conversion.Types import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..),symbol) import GF.Infra.Ident +import GF.Infra.Option (Options) import GF.Infra.Print import GF.Speech.CFGToFiniteState import GF.Speech.FiniteState @@ -36,23 +37,21 @@ import Data.Maybe (fromMaybe) -faGraphvizPrinter :: Ident -- ^ Grammar name - -> String -> StateGrammar -> String -faGraphvizPrinter name start = - prFAGraphviz . mapStates (const "") . cfgToFA start +faGraphvizPrinter :: Options -> StateGrammar -> String +faGraphvizPrinter opts s = + prFAGraphviz $ mapStates (const "") $ cfgToFA opts s -- | Convert the grammar to a regular grammar and print it in BNF -regularPrinter :: StateGrammar -> String -regularPrinter = prCFRules . makeSimpleRegular +regularPrinter :: Options -> StateGrammar -> String +regularPrinter opts s = prCFRules $ makeSimpleRegular s where prCFRules :: CFRules -> String prCFRules g = unlines [ c ++ " ::= " ++ join " | " (map (showRhs . ruleRhs) rs) | (c,rs) <- g] join g = concat . intersperse g showRhs = unwords . map (symbol id show) -faCPrinter :: Ident -- ^ Grammar name - -> String -> StateGrammar -> String -faCPrinter name start = fa2c . cfgToFA start +faCPrinter :: Options -> StateGrammar -> String +faCPrinter opts s = fa2c $ cfgToFA opts s fa2c :: DFA String -> String fa2c fa = undefined \ No newline at end of file diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs index c60b9eae4..bec461c40 100644 --- a/src/GF/Speech/PrGSL.hs +++ b/src/GF/Speech/PrGSL.hs @@ -31,11 +31,8 @@ import GF.Compile.ShellState (StateGrammar) import Data.Char (toUpper,toLower) -gslPrinter :: Ident -- ^ Grammar name - -> String -- ^ Start category - -> Options -> StateGrammar -> String -gslPrinter name start opts = - prGSL . topDownFilter . makeSimpleSRG name start opts +gslPrinter :: Options -> StateGrammar -> String +gslPrinter opts s = prGSL $ topDownFilter $ makeSimpleSRG opts s prGSL :: SRG -> String prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs index a94ae2ca2..d1d904dbb 100644 --- a/src/GF/Speech/PrJSGF.hs +++ b/src/GF/Speech/PrJSGF.hs @@ -38,13 +38,10 @@ import Text.PrettyPrint.HughesPJ import Debug.Trace -jsgfPrinter :: Ident -- ^ Grammar name - -> String -- ^ Start category +jsgfPrinter :: Maybe SISRFormat -> Options - -> Maybe SISRFormat -> StateGrammar -> String -jsgfPrinter name start opts sisr = - show . prJSGF sisr . makeSimpleSRG name start opts +jsgfPrinter sisr opts s = show $ prJSGF sisr $ makeSimpleSRG opts s prJSGF :: Maybe SISRFormat -> SRG -> Doc prJSGF sisr srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) diff --git a/src/GF/Speech/PrRegExp.hs b/src/GF/Speech/PrRegExp.hs index 0f661edac..50156c42b 100644 --- a/src/GF/Speech/PrRegExp.hs +++ b/src/GF/Speech/PrRegExp.hs @@ -12,11 +12,11 @@ module GF.Speech.PrRegExp (regexpPrinter) where import GF.Conversion.Types import GF.Infra.Ident +import GF.Infra.Option (Options) import GF.Speech.CFGToFiniteState import GF.Speech.RegExp import GF.Compile.ShellState (StateGrammar) -regexpPrinter :: Ident -- ^ Grammar name - -> String -> StateGrammar -> String -regexpPrinter name start = prRE . dfa2re . cfgToFA start +regexpPrinter :: Options -> StateGrammar -> String +regexpPrinter opts s = prRE $ dfa2re $ cfgToFA opts s diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index 08af81549..a608917b6 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -26,6 +26,7 @@ import GF.Conversion.Types import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..),symbol) import GF.Infra.Ident +import GF.Infra.Option (Options) import GF.Infra.Print import GF.Speech.CFGToFiniteState import GF.Speech.FiniteState @@ -54,9 +55,9 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } type SLF_FA = FA State (Maybe (MFALabel String)) () -mkFAs :: String -> StateGrammar -> (SLF_FA, [(String,SLF_FA)]) -mkFAs start s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) - where MFA main subs = {- renameSubs $ -} cfgToMFA start s +mkFAs :: Options -> StateGrammar -> (SLF_FA, [(String,SLF_FA)]) +mkFAs opts s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) + where MFA main subs = {- renameSubs $ -} cfgToMFA opts s slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) () slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () @@ -76,9 +77,9 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs' -- * SLF graphviz printing (without sub-networks) -- -slfGraphvizPrinter :: Ident -> String -> StateGrammar -> String -slfGraphvizPrinter name start - = prFAGraphviz . gvFA . slfStyleFA . cfgToFA' start +slfGraphvizPrinter :: Options -> StateGrammar -> String +slfGraphvizPrinter opts s + = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts s where gvFA = mapStates (fromMaybe "") . mapTransitions (const "") @@ -86,10 +87,9 @@ slfGraphvizPrinter name start -- * SLF graphviz printing (with sub-networks) -- -slfSubGraphvizPrinter :: Ident -- ^ Grammar name - -> String -> StateGrammar -> String -slfSubGraphvizPrinter name start s = Dot.prGraphviz g - where (main, subs) = mkFAs start s +slfSubGraphvizPrinter :: Options -> StateGrammar -> String +slfSubGraphvizPrinter opts s = Dot.prGraphviz g + where (main, subs) = mkFAs opts s g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs m = gvSLFFA Nothing main @@ -114,20 +114,19 @@ gvSLFFA n fa = -- * SLF printing (without sub-networks) -- -slfPrinter :: Ident -> String -> StateGrammar -> String -slfPrinter name start - = prSLF . automatonToSLF mkSLFNode . slfStyleFA . cfgToFA' start +slfPrinter :: Options -> StateGrammar -> String +slfPrinter opts s + = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts s -- -- * SLF printing (with sub-networks) -- -- | Make a network with subnetworks in SLF -slfSubPrinter :: Ident -- ^ Grammar name - -> String -> StateGrammar -> String -slfSubPrinter name start s = prSLFs slfs +slfSubPrinter :: Options -> StateGrammar -> String +slfSubPrinter opts s = prSLFs slfs where - (main,subs) = mkFAs start s + (main,subs) = mkFAs opts s slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main) faToSLF = automatonToSLF mfaNodeToSLFNode diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs index b68477f62..f3e08fc22 100644 --- a/src/GF/Speech/PrSRGS.hs +++ b/src/GF/Speech/PrSRGS.hs @@ -36,14 +36,11 @@ import qualified Data.Map as Map import qualified Data.Set as Set -srgsXmlPrinter :: Ident -- ^ Grammar name - -> String -- ^ Start category - -> Options - -> Maybe SISRFormat +srgsXmlPrinter :: Maybe SISRFormat -> Bool -- ^ Include probabilities - -> StateGrammar -> String -srgsXmlPrinter name start opts sisr probs = - prSrgsXml sisr probs . makeSRG name start opts + -> Options + -> StateGrammar -> String +srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSRG opts s prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start, diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index e9081abab..cf74ba66e 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -42,7 +42,7 @@ import GF.Speech.FiniteState import GF.Speech.RegExp import GF.Infra.Option import GF.Probabilistic.Probabilistic (Probs) -import GF.Compile.ShellState (StateGrammar, stateProbs) +import GF.Compile.ShellState (StateGrammar, stateProbs, cncId) import Data.List import Data.Maybe (fromMaybe, maybeToList) @@ -81,45 +81,37 @@ type CatNames = Map String String -- | Create a non-left-recursive SRG. -- FIXME: the probabilities, names and profiles in the returned -- grammar may be meaningless. -makeSimpleSRG :: Ident -- ^ Grammar name - -> String -- ^ Start category - -> Options -- ^ Grammar options +makeSimpleSRG :: Options -- ^ Grammar options -> StateGrammar -> SRG -makeSimpleSRG i origStart opts s = - makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s - where preprocess = removeLeftRecursion origStart . removeIdenticalRules - . removeEmptyCats . removeCycles - probs = stateProbs s +makeSimpleSRG opts s = + makeSRG_ (removeLeftRecursion origStart . removeIdenticalRules + . removeEmptyCats . removeCycles) opts s + where origStart = getStartCatCF opts s -- | Create a SRG preserving the names, profiles and probabilities of the -- input grammar. The returned grammar may be left-recursive. -makeSRG :: Ident -- ^ Grammar name - -> String -- ^ Start category - -> Options -- ^ Grammar options +makeSRG :: Options -- ^ Grammar options -> StateGrammar -> SRG -makeSRG i origStart opts s = - makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s - where preprocess = removeEmptyCats - probs = stateProbs s +makeSRG = makeSRG_ removeEmptyCats -makeSRG_ :: Ident -- ^ Grammar name - -> String -- ^ Start category - -> Options -- ^ Grammar options - -> Probs -- ^ Probabilities - -> CFRules -- ^ A context-free grammar +makeSRG_ :: (CFRules -> CFRules) + -> Options -- ^ Grammar options + -> StateGrammar -> SRG -makeSRG_ i origStart opts probs gr = +makeSRG_ preprocess opts s = SRG { grammarName = name, startCat = lookupFM_ names origStart, origStartCat = origStart, grammarLanguage = l, rules = rs } where - name = prIdent i + name = prIdent (cncId s) + origStart = getStartCatCF opts s + probs = stateProbs s l = fromMaybe "en_UK" (getOptVal opts speechLanguage) - (cats,cfgRules) = unzip gr + (cats,cfgRules) = unzip $ preprocess $ cfgToCFRules s names = mkCatNames name cats rs = map (cfgRulesToSRGRule names probs) cfgRules diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index 923e90d7c..3a167eeef 100644 --- a/src/GF/Speech/TransformCFG.hs +++ b/src/GF/Speech/TransformCFG.hs @@ -24,6 +24,7 @@ module GF.Speech.TransformCFG {- (CFRule_, CFRules, removeEmptyCats, removeIdenticalRules) -} where import GF.Conversion.Types +import GF.CF.PPrCF (prCFCat) import GF.Data.Utilities import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, @@ -32,7 +33,7 @@ import GF.Infra.Ident import GF.Infra.Option import GF.Infra.Print import GF.Speech.Relation -import GF.Compile.ShellState (StateGrammar, stateCFG) +import GF.Compile.ShellState (StateGrammar, stateCFG, startCatStateOpts) import Control.Monad import Control.Monad.State (State, get, put, evalState) @@ -76,6 +77,13 @@ cfgToCFRules s = profileToTerm (Unify xs) = CFRes (last xs) -- FIXME: unify profileToTerm (Constant f) = maybe CFMeta (\x -> CFObj x []) (forestName f) +getStartCat :: Options -> StateGrammar -> String +getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr) + +getStartCatCF :: Options -> StateGrammar -> String +getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" + + -- | Remove productions which use categories which have no productions removeEmptyCats :: CFRules -> CFRules removeEmptyCats = fix removeEmptyCats' diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 992019aee..291b8405d 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -248,51 +248,22 @@ customGrammarPrinter = ,(strCI "cf", \_ -> prCF . stateCF) ,(strCI "old", \_ -> printGrammarOld . stateGrammarST) ,(strCI "srg", \_ -> prSRG . stateCF) - ,(strCI "gsl", \opts s -> let name = cncId s - start = getStartCatCF opts s - in gslPrinter name start opts s) - ,(strCI "jsgf", \opts s -> let name = cncId s - start = getStartCatCF opts s - in jsgfPrinter name start opts Nothing s) - ,(strCI "jsgf_sisr_old", - \opts s -> let name = cncId s - start = getStartCatCF opts s - in jsgfPrinter name start opts (Just SISR.SISROld) s) - ,(strCI "srgs_xml", \opts s -> let name = cncId s - start = getStartCatCF opts s - in SRGS.srgsXmlPrinter name start opts Nothing False s) - ,(strCI "srgs_xml_prob", - \opts s -> let name = cncId s - start = getStartCatCF opts s - in SRGS.srgsXmlPrinter name start opts Nothing True s) - ,(strCI "srgs_xml_sisr_old", - \opts s -> let name = cncId s - start = getStartCatCF opts s - in SRGS.srgsXmlPrinter name start opts (Just SISR.SISROld) False s) + ,(strCI "gsl", gslPrinter) + ,(strCI "jsgf", jsgfPrinter Nothing) + ,(strCI "jsgf_sisr_old", jsgfPrinter (Just SISR.SISROld)) + ,(strCI "srgs_xml", SRGS.srgsXmlPrinter Nothing False) + ,(strCI "srgs_xml_prob", SRGS.srgsXmlPrinter Nothing True) + ,(strCI "srgs_xml_sisr_old", SRGS.srgsXmlPrinter (Just SISR.SISROld) False) ,(strCI "vxml", \opts s -> let start = cfCat2Ident (startCatStateOpts opts s) in grammar2vxml start s) - ,(strCI "slf", \opts s -> let start = getStartCatCF opts s - name = cncId s - in slfPrinter name start s) - ,(strCI "slf_graphviz", \opts s -> let start = getStartCatCF opts s - name = cncId s - in slfGraphvizPrinter name start s) - ,(strCI "slf_sub", \opts s -> let start = getStartCatCF opts s - name = cncId s - in slfSubPrinter name start s) - ,(strCI "slf_sub_graphviz", \opts s -> let start = getStartCatCF opts s - name = cncId s - in slfSubGraphvizPrinter name start s) - ,(strCI "fa_graphviz", \opts s -> let start = getStartCatCF opts s - name = cncId s - in faGraphvizPrinter name start s) - ,(strCI "fa_c", \opts s -> let start = getStartCatCF opts s - name = cncId s - in faCPrinter name start s) - ,(strCI "regexp", \opts s -> let start = getStartCatCF opts s - name = cncId s - in regexpPrinter name start s) - ,(strCI "regular", \_ -> regularPrinter) + ,(strCI "slf", slfPrinter) + ,(strCI "slf_graphviz", slfGraphvizPrinter) + ,(strCI "slf_sub", slfSubPrinter) + ,(strCI "slf_sub_graphviz", slfSubGraphvizPrinter) + ,(strCI "fa_graphviz", faGraphvizPrinter) + ,(strCI "fa_c", faCPrinter) + ,(strCI "regexp", regexpPrinter) + ,(strCI "regular", regularPrinter) ,(strCI "plbnf", \_ -> prLBNF True) ,(strCI "lbnf", \_ -> prLBNF False) ,(strCI "bnf", \_ -> prBNF False) @@ -345,9 +316,6 @@ customGrammarPrinter = -- ,(strCI "cfg-old", PrtOld.prt . CnvOld.cfg . statePInfoOld) ] where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s) - getStartCat,getStartCatCF :: Options -> StateGrammar -> String - getStartCat opts sgr = prCFCat (startCatStateOpts opts sgr) - getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" customMultiGrammarPrinter = customData "Printers for multiple grammars, selected by option -printer=x" $