Use grammar name as gsl category name prefix. Put some grammar info in GSL comments.

2 files changed, 31 insertions, 17 deletions

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index 4598885ff..259e7a023 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -43,48 +43,57 @@ import Data.Maybe (fromMaybe)
 import Data.FiniteMap
 
 
-data GSLGrammar = GSLGrammar String [GSLRule]
+data GSLGrammar = GSLGrammar String  -- ^ grammar name
+		             String  -- ^ start category name
+			     [GSLRule]
 data GSLRule = GSLRule String [GSLAlt]
 type GSLAlt = [Symbol String Token]
 
 type CatNames = FiniteMap String String
 
-gslPrinter :: Options -> CFGrammar -> String
-gslPrinter opts = prGSL start
+gslPrinter :: Ident -- ^ Grammar name
+	   -> Options -> CFGrammar -> String
+gslPrinter name opts = prGSL (prIdent name) start
     where mstart = getOptVal opts gStartCat
 	  start = fromMaybe "S" mstart ++ "{}.s"
 
-prGSL :: String -- ^ startcat
+prGSL :: String -- ^ Grammar name 
+      -> String -- ^ startcat
       -> CFGrammar -> String
-prGSL start cfg = prGSLGrammar names gsl ""
+prGSL name start cfg = prGSLGrammar names gsl ""
     where
     cfg' = makeNice cfg
-    gsl = cfgToGSL start cfg'
-    names = mkCatNames "GSL_" gsl
+    gsl = cfgToGSL name start cfg'
+    names = mkCatNames gsl
 
-cfgToGSL :: String  -- ^ startcat
+cfgToGSL :: String  -- ^ grammar name
+	 -> String  -- ^ start category
 	 -> [CFRule_] -> GSLGrammar
-cfgToGSL start = 
-    GSLGrammar start . map cfgRulesToGSLRule . sortAndGroupBy ruleCat
+cfgToGSL name start = 
+    GSLGrammar name start . map cfgRulesToGSLRule . sortAndGroupBy ruleCat
     where
     ruleCat (Rule c _ _) = c
     ruleRhs (Rule _ r _) = r
     cfgRulesToGSLRule rs@(r:_) = GSLRule (ruleCat r) (map ruleRhs rs)
 
-mkCatNames :: String -- name prefix
-	   -> GSLGrammar -> CatNames
-mkCatNames pref (GSLGrammar start rules) = 
+mkCatNames :: GSLGrammar -> CatNames
+mkCatNames (GSLGrammar name start rules) = 
     listToFM (zipWith dotIfStart lhsCats names)
-    where names = [pref ++ show x | x <- [0..]]
+    where names = [name ++ "_" ++ show x | x <- [0..]]
 	  lhsCats = [ c | GSLRule c _ <- rules]
 	  dotIfStart c n | c == start = (c, "." ++ n)
 			 | otherwise = (c, n)
 
 prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
-prGSLGrammar names (GSLGrammar start g) = header . unlinesS (map prGSLrule g)
+prGSLGrammar names (GSLGrammar name start g) = 
+    header . unlinesS (map prGSLrule g)
     where
     header = showString ";GSL2.0" . nl 
-	     . showString ("; startcat = " ++ start ) . nl
+	     . comments ["Nuance speech synthesis grammar for " ++ name,
+			 "Generated by GF",
+			 "Start category: " ++ start 
+			 ++ " (" ++ prGSLCat start ")"]
+	     . nl . nl
     prGSLrule (GSLRule cat rhs) = 
       showString "; " . prtS cat . nl
         . prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
@@ -105,6 +114,9 @@ rmPunct (s:ss) = s : rmPunct ss
 isPunct :: Char -> Bool
 isPunct c = c `elem` "-_.;.,?!"
 
+comments :: [String] -> ShowS
+comments = unlinesS . map (showString . ("; " ++))
+
 --
 -- * Utils
 --
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 856f31b01..f719d7bec 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -191,7 +191,9 @@ customGrammarPrinter =
   ,(strCI "cf",      prCF . stateCF)
   ,(strCI "old",     printGrammarOld . stateGrammarST)
   ,(strCI "srg",     prSRG . stateCF)
-  ,(strCI "gsl",  \s -> gslPrinter (stateOptions s) $ Cnv.cfg $ statePInfo s)
+  ,(strCI "gsl",     \s -> let opts = stateOptions s
+                               name = cncId s
+                            in gslPrinter name opts $ Cnv.cfg $ statePInfo s)
   ,(strCI "lbnf",    prLBNF . stateCF)
   ,(strCI "haskell", grammar2haskell . stateGrammarST)
   ,(strCI "morpho",  prMorpho . stateMorpho)