diff --git a/src-3.0/GF/Speech/PrGSL.hs b/src-3.0/GF/Speech/PrGSL.hs new file mode 100644 index 000000000..248991380 --- /dev/null +++ b/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