From a47fcbcbf23ead0cf3d7144ee23906bd5f6cb440 Mon Sep 17 00:00:00 2001 From: bjorn Date: Mon, 16 Jun 2008 16:44:33 +0000 Subject: [PATCH] Handled renaming external SRG categories centrally. --- src-3.0/GF/Speech/CFG.hs | 5 +++++ src-3.0/GF/Speech/JSGF.hs | 9 ++------- src-3.0/GF/Speech/SRG.hs | 38 +++++++++++++++++------------------ src-3.0/GF/Speech/SRGS_XML.hs | 10 +++------ 4 files changed, 28 insertions(+), 34 deletions(-) diff --git a/src-3.0/GF/Speech/CFG.hs b/src-3.0/GF/Speech/CFG.hs index a99a9d011..dfcecf913 100644 --- a/src-3.0/GF/Speech/CFG.hs +++ b/src-3.0/GF/Speech/CFG.hs @@ -242,6 +242,11 @@ catRules gr c = Set.toList $ Map.findWithDefault Set.empty c (cfgRules gr) catSetRules :: CFG -> Set Cat -> [CFRule] catSetRules gr cs = allRules $ filterCFGCats (`Set.member` cs) gr +mapCFGCats :: (Cat -> Cat) -> CFG -> CFG +mapCFGCats f cfg = mkCFG (f (cfgStartCat cfg)) + (Set.map f (cfgExternalCats cfg)) + [CFRule (f lhs) (map (mapSymbol f id) rhs) t | CFRule lhs rhs t <- allRules cfg] + onCFG :: (Map Cat (Set CFRule) -> Map Cat (Set CFRule)) -> CFG -> CFG onCFG f cfg = cfg { cfgRules = f (cfgRules cfg) } diff --git a/src-3.0/GF/Speech/JSGF.hs b/src-3.0/GF/Speech/JSGF.hs index d49646152..dc9f4170a 100644 --- a/src-3.0/GF/Speech/JSGF.hs +++ b/src-3.0/GF/Speech/JSGF.hs @@ -44,10 +44,8 @@ prJSGF sisr srg comment "Generated by GF" $$ text ("grammar " ++ srgName srg ++ ";") lang = maybe empty text (srgLanguage srg) - mainCat = rule True "MAIN" [prCat (externalCat (srgStartCat srg))] - prRule (SRGRule cat rhs) - | isExternalCat srg cat = rule True (externalCat cat) (map prAlt rhs) - | otherwise = rule False cat (map prAlt rhs) + mainCat = rule True "MAIN" [prCat (srgStartCat srg)] + prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] where initTag | isEmpty t = empty | otherwise = text "" <+> t @@ -55,9 +53,6 @@ prJSGF sisr srg finalTag = tag sisr (profileFinalSISR n) p = if isEmpty initTag && isEmpty finalTag then id else parens -externalCat :: Cat -> Cat -externalCat c = c ++ "_cat" - prCat :: Cat -> Doc prCat c = char '<' <> text c <> char '>' diff --git a/src-3.0/GF/Speech/SRG.hs b/src-3.0/GF/Speech/SRG.hs index defd647d7..e331f1881 100644 --- a/src-3.0/GF/Speech/SRG.hs +++ b/src-3.0/GF/Speech/SRG.hs @@ -96,17 +96,12 @@ stats g = "Categories: " ++ show (countCats g) makeNonRecursiveSRG :: PGF -> CId -- ^ Concrete syntax name. -> SRG -makeNonRecursiveSRG pgf cnc = - SRG { srgName = prCId cnc, - srgStartCat = start, - srgExternalCats = cfgExternalCats cfg, - srgLanguage = getSpeechLanguage pgf cnc, - srgRules = rs } - where - cfg = pgfToCFG pgf cnc - MFA start dfas = cfgToMFA cfg - rs = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas] - where dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re +makeNonRecursiveSRG = mkSRG mkRules + where + mkRules cfg = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas] + where + MFA _ dfas = cfgToMFA cfg + dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re dummyCFTerm = CFMeta (mkCId "dummy") dummySRGNT = mapSymbol (\c -> (c,0)) id @@ -114,16 +109,19 @@ makeSRG :: (CFG -> CFG) -> PGF -> CId -- ^ Concrete syntax name. -> SRG -makeSRG preprocess pgf cnc = - SRG { srgName = prCId cnc, - srgStartCat = cfgStartCat cfg, - srgExternalCats = cfgExternalCats cfg, - srgLanguage = getSpeechLanguage pgf cnc, - srgRules = rs } +makeSRG preprocess = mkSRG mkRules where - cfg = pgfToCFG pgf cnc - (_,cfgRules) = unzip $ allRulesGrouped $ preprocess cfg - rs = map cfRulesToSRGRule cfgRules + mkRules = map cfRulesToSRGRule . snd . unzip . allRulesGrouped . preprocess + +mkSRG :: (CFG -> [SRGRule]) -> PGF -> CId -> SRG +mkSRG mkRules pgf cnc = + SRG { srgName = prCId cnc, + srgStartCat = cfgStartCat cfg, + srgExternalCats = cfgExternalCats cfg, + srgLanguage = getSpeechLanguage pgf cnc, + srgRules = mkRules cfg } + where cfg = renameExternal $ pgfToCFG pgf cnc + renameExternal cfg' = mapCFGCats (\c -> if c `Set.member` cfgExternalCats cfg' then c ++ "_cat" else c) cfg' getSpeechLanguage :: PGF -> CId -> Maybe String getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language") diff --git a/src-3.0/GF/Speech/SRGS_XML.hs b/src-3.0/GF/Speech/SRGS_XML.hs index e78a702da..33e2d0374 100644 --- a/src-3.0/GF/Speech/SRGS_XML.hs +++ b/src-3.0/GF/Speech/SRGS_XML.hs @@ -32,19 +32,15 @@ srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf prSrgsXml :: Maybe SISRFormat -> SRG -> String prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) where - xmlGr = grammar sisr (externalCat (srgStartCat srg)) (srgLanguage srg) $ + xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ [meta "description" ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), meta "generator" "Grammatical Framework"] ++ map ruleToXML (srgRules srg) - ruleToXML (SRGRule cat alts) - | isExternalCat srg cat = Tag "rule" [("id",externalCat cat),("scope","public")] (prRhs alts) - | otherwise = Tag "rule" [("id",cat)] (prRhs alts) + ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) + where pub = if isExternalCat srg cat then [("scope","public")] else [] prRhs rhss = [oneOf (map (mkProd sisr) rhss)] -externalCat :: Cat -> Cat -externalCat c = c ++ "_cat" - mkProd :: Maybe SISRFormat -> SRGAlt -> XML mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) where x = mkItem sisr n rhs