Use makeSimpleSRG everywhere and remove makeSRG. Reimplemented top-down filtering in terms of CFRules instead of SRG. Do top-down filtering in makeSimpleSRG.

4 files changed, 20 insertions, 33 deletions

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index bec461c40..4dabbd84b 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -32,7 +32,7 @@ import GF.Compile.ShellState (StateGrammar)
 import Data.Char (toUpper,toLower)
 
 gslPrinter :: Options -> StateGrammar -> String
-gslPrinter opts s = prGSL $ topDownFilter $ makeSimpleSRG opts s
+gslPrinter opts s = prGSL $ makeSimpleSRG opts s
 
 prGSL :: SRG -> String
 prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs
index b6af82d32..980cd3c03 100644
--- a/src/GF/Speech/PrSRGS.hs
+++ b/src/GF/Speech/PrSRGS.hs
@@ -40,7 +40,7 @@ srgsXmlPrinter :: Maybe SISRFormat
 	       -> Bool -- ^ Include probabilities
 	       -> Options 
                -> StateGrammar -> String
-srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSRG opts s
+srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSimpleSRG 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 20bdd4a41..d4a4439e1 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -20,9 +20,9 @@
 
 module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..),
                       SRGCat, SRGNT, CFTerm,
-                      makeSimpleSRG, makeSRG
+                       makeSimpleSRG
                      , lookupFM_, prtS
-                     , topDownFilter, cfgCatToGFCat, srgTopCats
+                     , cfgCatToGFCat, srgTopCats
                      , EBnfSRGAlt(..), EBnfSRGItem
                      , ebnfSRGAlts
                      ) where
@@ -79,28 +79,12 @@ type CatName = (SRGCat,String)
 type CatNames = Map String String
 
 -- | Create a non-left-recursive SRG. 
---   FIXME: the probabilities, names and profiles in the returned 
+--   FIXME: the probabilities in the returned 
 --   grammar may be meaningless.
 makeSimpleSRG :: Options   -- ^ Grammar options
 	      -> StateGrammar
 	      -> SRG
-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 :: Options   -- ^ Grammar options
-	-> StateGrammar
-	-> SRG
-makeSRG = makeSRG_ removeEmptyCats
-
-makeSRG_ :: (CFRules -> CFRules)
-         -> Options   -- ^ Grammar options
-	 -> StateGrammar
-	 -> SRG
-makeSRG_ preprocess opt s = 
+makeSimpleSRG opt s =
       SRG { grammarName = name,
 	    startCat = lookupFM_ names origStart,
 	    origStartCat = origStart,
@@ -113,6 +97,11 @@ makeSRG_ preprocess opt s =
     probs = stateProbs s
     l = fmap (replace '_' '-') $ getOptVal opts speechLanguage
     (cats,cfgRules) = unzip $ preprocess $ cfgToCFRules s
+    preprocess = removeLeftRecursion origStart 
+                 . removeEmptyCats 
+                 . topDownFilter origStart
+                 . removeIdenticalRules 
+                 . removeCycles
     names = mkCatNames name cats
     rs = map (cfgRulesToSRGRule names probs) cfgRules
 
@@ -145,17 +134,6 @@ mkCatNames prefix origNames = Map.fromList (zip origNames names)
     where names = [prefix ++ "_" ++ show x | x <- [0..]]
 
 
--- | Remove categories which are not reachable from the start category.
-topDownFilter :: SRG -> SRG
-topDownFilter srg@(SRG { startCat = start, rules = rs }) = srg { rules = rs' }
-  where 
-  rs' = [ r | r@(SRGRule c _ _) <- rs, c `Set.member` keep]
-  rhsCats = [ (c,c') | r@(SRGRule c _ ps) <- rs, 
-                       SRGAlt _ _ ss <- ps, 
-                       (c',_) <- filterCats ss]
-  uses = reflexiveClosure_ (allSRGCats srg) $ transitiveClosure $ mkRel rhsCats
-  keep = allRelated uses start
-
 allSRGCats :: SRG -> [String]
 allSRGCats SRG { rules = rs } = [c | SRGRule c _ _ <- rs]
 
diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs
index 37d90fb52..63078ac5c 100644
--- a/src/GF/Speech/TransformCFG.hs
+++ b/src/GF/Speech/TransformCFG.hs
@@ -227,6 +227,15 @@ removeCycles :: CFRules -> CFRules
 removeCycles = groupProds . removeCycles_ . ungroupProds
   where removeCycles_ rs = [r | r@(CFRule c rhs _) <- rs, rhs /= [Cat c]]
 
+-- * Top-down filtering
+
+-- | Remove categories which are not reachable from the start category.
+topDownFilter :: Cat_ -> CFRules -> CFRules
+topDownFilter start rules = filter ((`Set.member` keep) . fst) rules
+  where
+    rhsCats = [ (c, c') | (c,rs) <- rules, r <- rs, c' <- filterCats (ruleRhs r) ]
+    uses = reflexiveClosure_ (allCats rules) $ transitiveClosure $ mkRel rhsCats
+    keep = allRelated uses start
 
 -- | Get the sets of mutually recursive non-terminals for a grammar.
 mutRecCats :: Bool    -- ^ If true, all categories will be in some set.