Rename SRG categories after preprocessing, since pp may introduce illegal category names.

2 files changed, 17 insertions, 9 deletions

diff --git a/src-3.0/GF/Speech/CFG.hs b/src-3.0/GF/Speech/CFG.hs
index dfcecf913..5b2a0f2ca 100644
--- a/src-3.0/GF/Speech/CFG.hs
+++ b/src-3.0/GF/Speech/CFG.hs
@@ -169,9 +169,9 @@ removeLeftRecursion gr
 
     retainedLeftRecursive = filter (isLeftRecursive . NonTerminal) $ Set.toList retained
 
-mkCat :: CFSymbol -> CFSymbol -> Cat
-mkCat x y = showSymbol x ++ "-" ++ showSymbol y
-  where showSymbol = symbol id show
+    mkCat :: CFSymbol -> CFSymbol -> Cat
+    mkCat x y = showSymbol x ++ "-" ++ showSymbol y
+        where showSymbol = symbol id show
 
 -- | Get the sets of mutually recursive non-terminals for a grammar.
 mutRecCats :: Bool    -- ^ If true, all categories will be in some set.
diff --git a/src-3.0/GF/Speech/SRG.hs b/src-3.0/GF/Speech/SRG.hs
index e331f1881..bf43c091b 100644
--- a/src-3.0/GF/Speech/SRG.hs
+++ b/src-3.0/GF/Speech/SRG.hs
@@ -10,7 +10,6 @@
 ----------------------------------------------------------------------
 module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
                      , SRGNT, CFTerm
-                     , makeSRG
                      , makeSimpleSRG
                      , makeNonRecursiveSRG
                      , getSpeechLanguage
@@ -73,9 +72,10 @@ type SRGNT = (Cat, Int)
 makeSimpleSRG :: PGF
               -> CId -- ^ Concrete syntax name.
 	      -> SRG
-makeSimpleSRG = makeSRG preprocess 
+makeSimpleSRG pgf cnc = makeSRG preprocess pgf cnc
     where
-      preprocess = traceStats "After mergeIdentical"
+      preprocess =   renameCats (prCId cnc)
+                   . traceStats "After mergeIdentical"
                    . mergeIdentical
                    . traceStats "After removeLeftRecursion"
                    . removeLeftRecursion 
@@ -114,14 +114,22 @@ makeSRG preprocess = mkSRG mkRules
       mkRules = map cfRulesToSRGRule . snd . unzip . allRulesGrouped . preprocess
 
 mkSRG :: (CFG -> [SRGRule]) -> PGF -> CId -> SRG
-mkSRG mkRules pgf cnc =
+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'
+    where cfg = pgfToCFG pgf cnc
+
+-- | Renames all external cats C to C_cat, and all internal cats to
+--   GrammarName_N where N is an integer.
+renameCats :: String -> CFG -> CFG
+renameCats prefix cfg = mapCFGCats renameCat cfg
+  where renameCat c | isExternal c = c ++ "_cat"
+                    | otherwise = fromMaybe ("renameCats: " ++ c) (Map.lookup c names)
+        isExternal c = c `Set.member` cfgExternalCats cfg        
+        names = Map.fromList $ zip (allCats cfg) [prefix ++ "_" ++ show x | x <- [0..]]
 
 getSpeechLanguage :: PGF -> CId -> Maybe String
 getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language")