Handled renaming external SRG categories centrally.

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 "<NULL>" <+>  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