GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Speech/PrGSL.hs

@@ -0,0 +1,113 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrGSL
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/01 20:09:04 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.22 $
+--
+-- This module prints a CFG as a Nuance GSL 2.0 grammar.
+--
+-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
+-- categories in the grammar
+-----------------------------------------------------------------------------
+
+module GF.Speech.PrGSL (gslPrinter) where
+
+import GF.Data.Utilities
+import GF.Speech.SRG
+import GF.Speech.RegExp
+import GF.Infra.Ident
+
+import GF.Formalism.CFG
+import GF.Formalism.Utilities (Symbol(..))
+import GF.Conversion.Types
+import GF.Infra.Print
+import GF.Infra.Option
+import GF.Probabilistic.Probabilistic (Probs)
+import GF.Compile.ShellState (StateGrammar)
+
+import Data.Char (toUpper,toLower)
+import Data.List (partition)
+import Text.PrettyPrint.HughesPJ
+
+width :: Int
+width = 75
+
+gslPrinter :: Options -> StateGrammar -> String
+gslPrinter opts s = renderStyle st $ prGSL $ makeSimpleSRG opts s
+  where st = style { lineLength = width } 
+
+prGSL :: SRG -> Doc
+prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
+    = header $++$ mainCat $++$ foldr ($++$) empty (map prRule rs)
+    where
+    header = text ";GSL2.0" $$
+	     comment ("Nuance speech recognition grammar for " ++ name) $$
+             comment ("Generated by GF") 
+    mainCat = comment ("Start category: " ++ origStart) $$
+	      text ".MAIN" <+> prCat start
+    prRule (SRGRule cat origCat rhs) = 
+	comment (prt origCat) $$ 
+        prCat cat <+> union (map prAlt rhs)
+    -- FIXME: use the probability
+    prAlt (SRGAlt mp _ rhs) = prItem rhs
+
+
+prItem :: SRGItem -> Doc
+prItem = f
+  where
+    f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes)
+      where (es,nes) = partition isEpsilon xs
+    f (REConcat [x]) = f x
+    f (REConcat xs) = text "(" <> fsep (map f xs) <> text ")"
+    f (RERepeat x)  = text "*" <> f x
+    f (RESymbol s)  = prSymbol s
+
+union :: [Doc] -> Doc
+union [x] = x
+union xs = text "[" <> fsep xs <> text "]"
+
+prSymbol :: Symbol SRGNT Token -> Doc
+prSymbol (Cat (c,_)) = prCat c
+prSymbol (Tok t) = doubleQuotes (showToken t)
+
+-- GSL requires an upper case letter in category names
+prCat :: SRGCat -> Doc
+prCat c = text (firstToUpper c)
+
+
+firstToUpper :: String -> String
+firstToUpper [] = []
+firstToUpper (x:xs) = toUpper x : xs
+
+{-
+rmPunctCFG :: CGrammar -> CGrammar
+rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]
+
+keepSymbol :: Symbol c Token -> Bool
+keepSymbol (Tok t) = not (all isPunct (prt t))
+keepSymbol _ = True
+-}
+
+-- Nuance does not like upper case characters in tokens
+showToken :: Token -> Doc
+showToken t = text (map toLower (prt t))
+
+isPunct :: Char -> Bool
+isPunct c = c `elem` "-_.:;.,?!()[]{}"
+
+comment :: String -> Doc
+comment s = text ";" <+> text s
+
+
+-- Pretty-printing utilities
+
+emptyLine :: Doc
+emptyLine = text ""
+
+($++$) :: Doc -> Doc -> Doc
+x $++$ y = x $$ emptyLine $$ y