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/PrSRGS.hs

@@ -0,0 +1,153 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrSRGS
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- This module prints a CFG as an SRGS XML grammar.
+--
+-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
+-- categories in the grammar
+-----------------------------------------------------------------------------
+
+module GF.Speech.PrSRGS (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where
+
+import GF.Data.Utilities
+import GF.Data.XML
+import GF.Speech.RegExp
+import GF.Speech.SISR as SISR
+import GF.Speech.SRG
+import GF.Infra.Ident
+import GF.Today
+
+import GF.Formalism.CFG
+import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName, filterCats)
+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
+import Data.Maybe
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+srgsXmlPrinter :: Maybe SISRFormat 
+	       -> Bool -- ^ Include probabilities
+	       -> Options 
+               -> StateGrammar -> String
+srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSimpleSRG opts s
+
+srgsXmlNonRecursivePrinter :: Options -> StateGrammar -> String
+srgsXmlNonRecursivePrinter opts s = prSrgsXml Nothing False $ makeNonRecursiveSRG opts s
+
+
+prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String
+prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start,
+                        origStartCat=origStart,grammarLanguage=l,rules=rs})
+    = showXMLDoc (optimizeSRGS xmlGr)
+    where
+    Just root = cfgCatToGFCat origStart 
+    xmlGr = grammar sisr (catFormId root) l $
+              [meta "description" 
+               ("SRGS XML speech recognition grammar for " ++ name
+                ++ ". " ++ "Original start category: " ++ origStart),
+               meta "generator" ("Grammatical Framework " ++ version)]
+            ++ topCatRules
+	    ++ concatMap ruleToXML rs
+    ruleToXML (SRGRule cat origCat alts) = 
+        comments ["Category " ++ origCat] ++ [rule cat (prRhs alts)]
+    prRhs rhss = [oneOf (map (mkProd sisr probs) rhss)] 
+    -- externally visible rules for each of the GF categories
+    topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- srgTopCats srg]
+        where it i c = Tag "item" [] ([ETag "ruleref" [("uri","#" ++ c)]] 
+                                      ++ tag sisr (topCatSISR c))
+              topRule i is = Tag "rule" [("id",catFormId i),("scope","public")] is
+
+rule :: String -> [XML] -> XML
+rule i = Tag "rule" [("id",i)]
+
+mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML
+mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ [x] ++ tf)
+  where x = mkItem sisr n rhs
+        w | probs = maybe [] (\p -> [("weight", show p)]) mp
+          | otherwise = []
+        ti = tag sisr (profileInitSISR n)
+        tf = tag sisr (profileFinalSISR n)
+
+mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
+mkItem sisr cn = f
+  where 
+    f (REUnion [])  = ETag "ruleref" [("special","VOID")]
+    f (REUnion xs) 
+        | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
+        | otherwise = oneOf (map f xs)
+      where (es,nes) = partition isEpsilon xs
+    f (REConcat []) = ETag "ruleref" [("special","NULL")]
+    f (REConcat xs) = Tag "item" [] (map f xs)
+    f (RERepeat x)  = Tag "item" [("repeat","0-")] [f x]
+    f (RESymbol s)  = symItem sisr cn s
+
+{-
+mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML
+mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf)
+  where xs = mkItem sisr n rhs
+        w | probs = maybe [] (\p -> [("weight", show p)]) mp
+          | otherwise = []
+        ti = [tag sisr (profileInitSISR n)]
+        tf = [tag sisr (profileFinalSISR n)]
+
+
+mkItem :: Maybe SISRFormat -> CFTerm -> [Symbol SRGNT Token] -> [XML]
+mkItem sisr cn ss = map (symItem sisr cn) ss
+-}
+
+symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
+symItem sisr cn (Cat n@(c,_)) = 
+    Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
+symItem _ _ (Tok t) = Tag "item" [] [Data (showToken t)]
+
+tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
+tag Nothing _ = []
+tag (Just fmt) t = case t fmt of
+                     [] -> []
+                     ts -> [Tag "tag" [] [Data (prSISR ts)]]
+
+catFormId :: String -> String
+catFormId = (++ "_cat")
+
+
+showToken :: Token -> String
+showToken t = t
+
+oneOf :: [XML] -> XML
+oneOf = Tag "one-of" []
+
+grammar :: Maybe SISRFormat
+        -> String  -- ^ root
+        -> Maybe String -- ^language
+	-> [XML] -> XML
+grammar sisr root ml = 
+    Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
+		     ("version","1.0"),
+		     ("mode","voice"),
+		     ("root",root)]
+                 ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
+                 ++ maybe [] (\l -> [("xml:lang", l)]) ml
+
+meta :: String -> String -> XML
+meta n c = ETag "meta" [("name",n),("content",c)]
+
+optimizeSRGS :: XML -> XML
+optimizeSRGS = bottomUpXML f 
+  where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
+        f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
+        f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs
+        f (Tag "item" as xs) = Tag "item" as (map g xs)
+           where g (Tag "item" [] [x@(ETag "ruleref" _)]) = x
+                 g x = x
+        f (Tag "one-of" [] [x]) = x
+        f x = x