Generalized Speech Recognition Grammar generation. Added JSGF grammar printer.

src/GF/Speech/PrGSL.hs

@@ -11,96 +11,45 @@
 
     Created       : September 13, 2004
 
-    Modified      : 
+    Modified      : October 1, 2004
    ************************************************************** 
 -}
 
--- FIXME: this modules should not be in cfgm, but where?
-
--- FIXME: remove left-recursion
-
--- FIXME: remove empty rules
-
--- FIXME: remove categories with no RHS
-
 -- FIXME: remove / warn / fail if there are int / string literal
 -- categories in the grammar
 
--- FIXME: figure out name prefix from grammar name
-
 module PrGSL (gslPrinter) where
 
+import SRG
 import Ident
 import CFGrammar
 import Parser (Symbol(..))
 import GrammarTypes
 import PrintParser
-import TransformCFG
 import Option
 
-import Data.List
-import Data.Maybe (fromMaybe)
-import Data.FiniteMap
-
-
-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 :: Ident -- ^ Grammar name
 	   -> Options -> CFGrammar -> String
-gslPrinter name opts = prGSL (prIdent name) start
-    where mstart = getOptVal opts gStartCat
-	  start = fromMaybe "S" mstart ++ "{}.s"
+gslPrinter name opts cfg = prGSL srg ""
+    where srg = makeSRG name opts cfg
 
-prGSL :: String -- ^ Grammar name 
-      -> String -- ^ startcat
-      -> CFGrammar -> String
-prGSL name start cfg = prGSLGrammar names gsl ""
-    where
-    cfg' = makeNice cfg
-    gsl = cfgToGSL name start cfg'
-    names = mkCatNames gsl
-
-cfgToGSL :: String  -- ^ grammar name
-	 -> String  -- ^ start category
-	 -> [CFRule_] -> GSLGrammar
-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 :: GSLGrammar -> CatNames
-mkCatNames (GSLGrammar name start rules) = listToFM (zip lhsCats names)
-    where names = [name ++ "_" ++ show x | x <- [0..]]
-	  lhsCats = [ c | GSLRule c _ <- rules]
-
-prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
-prGSLGrammar names (GSLGrammar name start g) = 
-    header . mainCat . unlinesS (map prGSLrule g)
+prGSL :: SRG -> ShowS
+prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
+    = header . mainCat . unlinesS (map prRule rs)
     where
     header = showString ";GSL2.0" . nl 
 	     . comments ["Nuance speech recognition grammar for " ++ name,
 			 "Generated by GF"] . nl . nl
-    mainCat = showString ("; Start category: " ++ start) . nl 
-	      . showString ".MAIN " . prGSLCat start . nl . nl
-    prGSLrule (GSLRule cat rhs) = 
-      showString "; " . prtS cat . nl
-        . prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
-    prGSLAlt rhs = wrap "(" (unwordsS (map prGSLSymbol rhs')) ")"
+    mainCat = showString ("; Start category: " ++ origStart) . nl 
+	      . showString ".MAIN " . prCat start . nl . nl
+    prRule (SRGRule cat origCat rhs) = 
+	showString "; " . prtS origCat . nl
+        . prCat cat . sp . wrap "[" (unwordsS (map prAlt rhs)) "]" . nl
+    prAlt rhs = wrap "(" (unwordsS (map prSymbol rhs')) ")"
 		   where rhs' = rmPunct rhs
-    prGSLSymbol (Cat c) = prGSLCat c
-    prGSLSymbol (Tok t) = wrap "\"" (prtS t) "\""
-    prGSLCat c = showString n 
-	where n = case lookupFM names c of
-		    Nothing -> error $ "Unknown category: " ++ c
-		    Just x -> x
+    prSymbol (Cat c) = prCat c
+    prSymbol (Tok t) = wrap "\"" (prtS t) "\""
+    prCat c = showString c
 
 rmPunct :: [Symbol String Token] -> [Symbol String Token] 
 rmPunct [] = []
@@ -112,37 +61,3 @@ isPunct c = c `elem` "-_.;.,?!"
 
 comments :: [String] -> ShowS
 comments = unlinesS . map (showString . ("; " ++))
-
---
--- * Utils
---
-
-nl :: ShowS
-nl = showChar '\n'
-
-sp :: ShowS
-sp = showChar ' '
-
-wrap :: String -> ShowS -> String -> ShowS
-wrap o s c = showString o . s . showString c
-
-concatS :: [ShowS] -> ShowS
-concatS = foldr (.) id
-
-unwordsS :: [ShowS] -> ShowS
-unwordsS = concatS . intersperse sp 
-
-unlinesS :: [ShowS] -> ShowS
-unlinesS = concatS . intersperse nl
-
-sortAndGroupBy :: Ord b => 
-		  (a -> b) -- ^ Gets the value to sort and group by
-	       -> [a] 
-	       -> [[a]]
-sortAndGroupBy f = groupBy (both (==) f) . sortBy (both compare f)
-
-both :: (b -> b -> c) -> (a -> b) -> a -> a -> c
-both f g x y = f (g x) (g y)
-
-prtS :: Print a => a -> ShowS
-prtS = showString . prt