Fix handling of external categories in SRG generation.

5 files changed, 27 insertions, 13 deletions

diff --git a/src-3.0/GF/Speech/CFG.hs b/src-3.0/GF/Speech/CFG.hs
index 98d31c9f6..a99a9d011 100644
--- a/src-3.0/GF/Speech/CFG.hs
+++ b/src-3.0/GF/Speech/CFG.hs
@@ -80,12 +80,13 @@ bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty })
   where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr
         okSym g = symbol (`elem` allCats g) (const True)
 
--- | Removes categories which are not reachable from the start category.
+-- | Removes categories which are not reachable from any external category.
 topDownFilter :: CFG -> CFG
-topDownFilter cfg = filterCFGCats (isRelatedTo uses (cfgStartCat cfg)) cfg
+topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg
   where
     rhsCats = [ (lhsCat r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ]
     uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats
+    keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg
 
 -- | Merges categories with identical right-hand-sides.
 -- FIXME: handle probabilities
diff --git a/src-3.0/GF/Speech/JSGF.hs b/src-3.0/GF/Speech/JSGF.hs
index 53a40ffd4..d49646152 100644
--- a/src-3.0/GF/Speech/JSGF.hs
+++ b/src-3.0/GF/Speech/JSGF.hs
@@ -44,8 +44,10 @@ prJSGF sisr srg
              comment "Generated by GF" $$
 	     text ("grammar " ++ srgName srg ++ ";") 
     lang = maybe empty text (srgLanguage srg)
-    mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
-    prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
+    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)
     prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag]
       where initTag | isEmpty t = empty
                     | otherwise = text "<NULL>" <+>  t
@@ -53,8 +55,8 @@ prJSGF sisr srg
             finalTag = tag sisr (profileFinalSISR n)
             p = if isEmpty initTag && isEmpty finalTag then id else parens
 
-catFormId :: String -> String
-catFormId = (++ "_cat")
+externalCat :: Cat -> Cat
+externalCat c = c ++ "_cat"
 
 prCat :: Cat -> Doc
 prCat c = char '<' <> text c <> char '>'
diff --git a/src-3.0/GF/Speech/PGFToCFG.hs b/src-3.0/GF/Speech/PGFToCFG.hs
index a2dc32f32..168591e6b 100644
--- a/src-3.0/GF/Speech/PGFToCFG.hs
+++ b/src-3.0/GF/Speech/PGFToCFG.hs
@@ -45,16 +45,20 @@ pgfToCFG pgf lang = mkCFG (lookStartCat pgf) extCats (startRules ++ concatMap fr
     -- NOTE: this is only correct for cats that have a lincat with exactly one row.
     startRules :: [CFRule]
     startRules = [CFRule (prCId c) [NonTerminal (fcatToCat fc 0)] (CFRes 0) 
-                      | (c,fcs) <- Map.toList (startupCats pinfo), fc <- fcs]
+                      | (c,fcs) <- Map.toList (startupCats pinfo), 
+                        fc <- fcs, not (isLiteralFCat fc)]
 
     fruleToCFRule :: FRule -> [CFRule]
     fruleToCFRule (FRule f ps args c rhs) = 
         [CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm (map (fixProfile row) ps))
-         | (l,row) <- Array.assocs rhs]
+         | (l,row) <- Array.assocs rhs, not (containsLiterals row)]
       where
         mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
         mkRhs = map fsymbolToSymbol . Array.elems
 
+        containsLiterals :: Array FPointPos FSymbol -> Bool
+        containsLiterals row = any isLiteralFCat [args!!n | FSymCat _ n <- Array.elems row]
+
         fsymbolToSymbol :: FSymbol -> CFSymbol
         fsymbolToSymbol (FSymCat l n) = NonTerminal (fcatToCat (args!!n) l)
         fsymbolToSymbol (FSymTok t) = Terminal t
@@ -73,3 +77,6 @@ pgfToCFG pgf lang = mkCFG (lookStartCat pgf) extCats (startRules ++ concatMap fr
         profileToTerm :: CId -> Profile -> CFTerm
         profileToTerm t [] = CFMeta t
         profileToTerm _ xs = CFRes (last xs) -- FIXME: unify
+
+isLiteralFCat :: FCat -> Bool
+isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])
diff --git a/src-3.0/GF/Speech/SRG.hs b/src-3.0/GF/Speech/SRG.hs
index 8bb509d22..defd647d7 100644
--- a/src-3.0/GF/Speech/SRG.hs
+++ b/src-3.0/GF/Speech/SRG.hs
@@ -90,7 +90,8 @@ makeSimpleSRG = makeSRG preprocess
 traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g
 
 stats g = "Categories: " ++ show (countCats g)
-          ++ " Rules: " ++ show (countRules g)
+          ++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
+          ++ ", Rules: " ++ show (countRules g)
 
 makeNonRecursiveSRG :: PGF
                     -> CId -- ^ Concrete syntax name.
diff --git a/src-3.0/GF/Speech/SRGS_XML.hs b/src-3.0/GF/Speech/SRGS_XML.hs
index 97c1629fb..e78a702da 100644
--- a/src-3.0/GF/Speech/SRGS_XML.hs
+++ b/src-3.0/GF/Speech/SRGS_XML.hs
@@ -32,16 +32,19 @@ srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf
 prSrgsXml :: Maybe SISRFormat -> SRG -> String
 prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
     where
-    xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
+    xmlGr = grammar sisr (externalCat (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) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
-        where pub | isExternalCat srg cat = [("scope","public")]
-                  | otherwise = []
+    ruleToXML (SRGRule cat alts) 
+        | isExternalCat srg cat = Tag "rule" [("id",externalCat cat),("scope","public")] (prRhs alts)
+        | otherwise = Tag "rule" [("id",cat)] (prRhs alts)
     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