From 390efcd43c6bcca6a65002e6d35c2507bb975db9 Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Wed, 1 Feb 2006 19:00:48 +0000
Subject: [PATCH] SRGS: add top-level rules for each GF category.

---
 src/GF/Data/Utilities.hs |  5 +++++
 src/GF/Speech/PrSRGS.hs  | 10 +++++++++-
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
index c7e1600c3..e0ad08705 100644
--- a/src/GF/Data/Utilities.hs
+++ b/src/GF/Data/Utilities.hs
@@ -99,6 +99,11 @@ tableSet x y [] = [(x,y)]
 tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
                            | otherwise = p:tableSet x y xs
 
+-- | Group tuples by their first elements.
+buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])]
+buildMultiMap = map (\g -> (fst (head g), map snd g) )
+                 . sortGroupBy (compareBy fst)
+
 -- * equality functions
 
 -- | Use an ordering function as an equality predicate.
diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs
index 6e445d41a..60c2ba8e7 100644
--- a/src/GF/Speech/PrSRGS.hs
+++ b/src/GF/Speech/PrSRGS.hs
@@ -57,13 +57,21 @@ prSrgsXml sisr (SRG{grammarName=name,startCat=start,
                               ++ ". " ++ "Original start category: " ++ origStart),
                              meta "generator" ("Grammatical Framework " ++ version 
                                                ++ " (compiled " ++ today ++ ")")]
-			  ++ map ruleToXML rs)
+                            ++ topCatRules
+			    ++ map ruleToXML rs)
     ruleToXML (SRGRule cat origCat alts) = 
 	rule (prCat cat) (comments ["Category " ++ origCat] ++ prRhs isList alts)
       where isList = "List" `isPrefixOf` origCat && length cs == 2
                       && isBase (cs!!0) && isCons (cs!!1)
             cs = sortNub [f | SRGAlt _ (Name f _) _ <- alts]
     prRhs isList rhss = [oneOf (map (mkProd sisr isList) rhss)] 
+    -- externally visible rules for each of the GF categories
+    topCatRules = [topRule tc [oneOf (map it cs)] | (tc,cs) <- topCats]
+        where topCats = buildMultiMap [(gfCat origCat, cat) | SRGRule cat origCat _ <- rs]
+              gfCat = takeWhile (/='{')
+              it c = symItem [] (Cat c) 0
+              topRule i is = Tag "rule" [("id",i),("scope","public")] 
+                             (is ++ [tag ["$ = $$"]])
 
 rule :: String -> [XML] -> XML
 rule i = Tag "rule" [("id",i)]