Added (still unchanged) GF.Speech.VoiceXML.

1 files changed, 285 insertions, 0 deletions

diff --git a/src-3.0/GF/Speech/VoiceXML.hs b/src-3.0/GF/Speech/VoiceXML.hs
new file mode 100644
index 000000000..ad7f25d1c
--- /dev/null
+++ b/src-3.0/GF/Speech/VoiceXML.hs
@@ -0,0 +1,285 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToVoiceXML
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Create VoiceXML dialogue system from a GF grammar.
+-----------------------------------------------------------------------------
+
+module GF.Speech.GrammarToVoiceXML (grammar2vxml) where
+
+import GF.Canon.CanonToGFCC (canon2gfcc)
+import qualified GF.GFCC.CId as C
+import GF.GFCC.DataGFCC (GFCC(..), Abstr(..))
+import GF.GFCC.Macros
+import qualified GF.Canon.GFC as GFC
+import GF.Canon.AbsGFC (Term)
+import GF.Canon.PrintGFC (printTree)
+import GF.Canon.CMacros (noMark, strsFromTerm)
+import GF.Canon.Unlex (formatAsText)
+import GF.Data.Utilities
+import GF.CF.CFIdent (cfCat2Ident)
+import GF.Compile.ShellState (StateGrammar,stateGrammarST,cncId,grammar,
+                              startCatStateOpts,stateOptions)
+import GF.Data.Str (sstrV)
+import GF.Grammar.Macros hiding (assign,strsFromTerm)
+import GF.Grammar.Grammar (Fun)
+import GF.Grammar.Values (Tree)
+import GF.Infra.Option (Options, addOptions, getOptVal, speechLanguage)
+import GF.UseGrammar.GetTree (string2treeErr)
+import GF.UseGrammar.Linear (linTree2strings)
+
+import GF.Infra.Ident
+import GF.Infra.Option (noOptions)
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import GF.Data.XML
+
+import Control.Monad (liftM)
+import Data.List (isPrefixOf, find, intersperse)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+
+import Debug.Trace
+
+-- | the main function
+grammar2vxml :: Options -> StateGrammar -> String
+grammar2vxml opt s = showsXMLDoc (skel2vxml name language startcat gr' qs) ""
+    where (_, gr') = vSkeleton (stateGrammarST s)
+          name = prIdent (cncId s)
+          qs = catQuestions s (map fst gr')
+          opts = addOptions opt (stateOptions s)
+          language = fmap (replace '_' '-') $ getOptVal opts speechLanguage
+          startcat = C.CId $ prIdent $ cfCat2Ident $ startCatStateOpts opts s
+
+--
+-- * VSkeleton: a simple description of the abstract syntax.
+--
+
+type VSkeleton = [(VIdent, [(VIdent, [VIdent])])]
+type VIdent = C.CId
+
+prid :: VIdent -> String
+prid (C.CId x) = x
+
+vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton)
+vSkeleton = gfccSkeleton . canon2gfcc noOptions
+
+gfccSkeleton :: GFCC -> (VIdent,VSkeleton)
+gfccSkeleton gfcc = (absname gfcc, ts)
+  where a = abstract gfcc
+        ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (catfuns a)]
+        ft f = case lookMap (error $ prid f) f (funs a) of
+                 (ty,_) -> fst $ GF.GFCC.Macros.catSkeleton ty
+
+--
+-- * Questions to ask 
+--
+
+type CatQuestions = [(VIdent,String)]
+
+catQuestions :: StateGrammar -> [VIdent] -> CatQuestions
+catQuestions gr cats = [(c,catQuestion gr c) | c <- cats]
+
+catQuestion :: StateGrammar -> VIdent -> String
+catQuestion gr cat = err errHandler id (getPrintname gr cat >>= term2string)
+  where -- FIXME: use some better warning facility
+        errHandler e = trace ("GrammarToVoiceXML: " ++ e) ("quest_"++prid cat)
+        term2string = liftM sstrV . strsFromTerm
+
+getPrintname :: StateGrammar -> VIdent -> Err Term
+getPrintname gr cat = 
+    do m <- lookupModMod (grammar gr) (cncId gr)
+       i <- lookupInfo m (IC (prid cat))
+       case i of
+         GFC.CncCat _ _ p -> return p
+         _ -> fail $ "getPrintname " ++ prid cat
+                      ++ ": Expected CncCat, got " ++ show i
+
+
+{-
+lin :: StateGrammar -> String -> Err String
+lin gr fun = do
+             tree <- string2treeErr gr fun
+             let ls = map unt $ linTree2strings noMark g c tree
+             case ls of
+                 [] -> fail $ "No linearization of " ++ fun
+                 l:_ -> return l
+  where c = cncId gr
+        g = stateGrammarST gr
+        unt = formatAsText 
+-}
+
+getCatQuestion :: VIdent -> CatQuestions -> String
+getCatQuestion c qs = 
+    fromMaybe (error "No question for category " ++ prid c) (lookup c qs)
+
+--
+-- * Generate VoiceXML
+--
+
+skel2vxml :: String -> Maybe String -> VIdent -> VSkeleton -> CatQuestions -> XML
+skel2vxml name language start skel qs = 
+    vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel)
+  where 
+  gr = grammarURI name
+  startForm = Tag "form" [] [subdialog "sub" [("src", "#"++catFormId start)] 
+                                           [param "old" "{ name : '?' }"]]
+
+grammarURI :: String -> String
+grammarURI name = name ++ ".grxml"
+
+
+catForms :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> [XML]
+catForms gr qs cat fs = 
+    comments [prid cat ++ " category."]
+    ++ [cat2form gr qs cat fs] 
+
+cat2form :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> XML
+cat2form gr qs cat fs = 
+  form (catFormId cat) $ 
+      [var "old" Nothing, 
+       blockCond "old.name != '?'" [assign "term" "old"],
+       field "term" []
+           [promptString (getCatQuestion cat qs), 
+            vxmlGrammar (gr++"#"++catFormId cat)
+           ]
+      ]
+     ++ concatMap (uncurry (fun2sub gr cat)) fs
+     ++ [block [return_ ["term"]{-]-}]]
+
+fun2sub :: String -> VIdent -> VIdent -> [VIdent] -> [XML]
+fun2sub gr cat fun args = 
+    comments [prid fun ++ " : (" 
+              ++ concat (intersperse ", " (map prid args))
+              ++ ") " ++ prid cat] ++ ss
+  where 
+  ss = zipWith mkSub [0..] args
+  mkSub n t = subdialog s [("src","#"++catFormId t),
+                           ("cond","term.name == "++string (prid fun))] 
+              [param "old" v,
+               filled [] [assign v (s++".term")]]
+    where s = prid fun ++ "_" ++ show n
+          v = "term.args["++show n++"]"
+
+catFormId :: VIdent -> String
+catFormId c = prid c ++ "_cat"
+
+
+--
+-- * VoiceXML stuff
+--
+
+vxml :: Maybe String -> [XML] -> XML
+vxml ml = Tag "vxml" $ [("version","2.0"),
+                        ("xmlns","http://www.w3.org/2001/vxml")]
+                      ++ maybe [] (\l -> [("xml:lang", l)]) ml
+
+form :: String -> [XML] -> XML
+form id xs = Tag "form" [("id", id)] xs
+
+field :: String -> [(String,String)] -> [XML] -> XML
+field name attrs = Tag "field" ([("name",name)]++attrs)
+
+subdialog :: String -> [(String,String)] -> [XML] -> XML
+subdialog name attrs = Tag "subdialog" ([("name",name)]++attrs)
+
+filled :: [(String,String)] -> [XML] -> XML
+filled = Tag "filled"
+
+vxmlGrammar :: String -> XML
+vxmlGrammar uri = ETag "grammar" [("src",uri)]
+
+prompt :: [XML] -> XML
+prompt = Tag "prompt" []
+
+promptString :: String -> XML
+promptString p = prompt [Data p]
+
+reprompt :: XML
+reprompt = ETag "reprompt" []
+
+assign :: String -> String -> XML
+assign n e = ETag "assign" [("name",n),("expr",e)]
+
+value :: String -> XML
+value expr = ETag "value" [("expr",expr)]
+
+if_ :: String -> [XML] -> XML
+if_ c b = if_else c b []
+
+if_else :: String -> [XML] -> [XML] -> XML
+if_else c t f = cond [(c,t)] f
+
+cond :: [(String,[XML])] -> [XML] -> XML
+cond ((c,b):rest) els = Tag "if" [("cond",c)] (b ++ es)
+  where es = [Tag "elseif" [("cond",c')] b' | (c',b') <- rest] 
+             ++ if null els then [] else (Tag "else" [] []:els)
+
+goto_item :: String -> XML
+goto_item nextitem = ETag "goto" [("nextitem",nextitem)]
+
+return_ :: [String] -> XML
+return_ names = ETag "return" [("namelist", unwords names)]
+
+block :: [XML] -> XML
+block = Tag "block" []
+
+blockCond :: String -> [XML] -> XML
+blockCond cond = Tag "block" [("cond", cond)]
+
+throw :: String -> String -> XML
+throw event msg = Tag "throw" [("event",event),("message",msg)] []
+
+nomatch :: [XML] -> XML
+nomatch = Tag "nomatch" []
+
+help :: [XML] -> XML
+help = Tag "help" []
+
+param :: String -> String -> XML
+param name expr = ETag "param" [("name",name),("expr",expr)]
+
+var :: String -> Maybe String -> XML
+var name expr = ETag "var" ([("name",name)]++e)
+  where e = maybe [] ((:[]) . (,) "expr") expr
+
+script :: String -> XML
+script s = Tag "script" [] [CData s]
+
+scriptURI :: String -> XML
+scriptURI uri = Tag "script" [("uri", uri)] []
+
+--
+-- * ECMAScript stuff
+--
+
+string :: String -> String
+string s = "'" ++ concatMap esc s ++ "'"
+  where esc '\'' = "\\'"
+        esc c    = [c]
+
+{-
+--
+-- * List stuff
+--
+
+isListCat :: (VIdent, [(VIdent, [VIdent])]) -> Bool
+isListCat (cat,rules) = "List" `isPrefixOf` prIdent cat && length rules == 2
+		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where c = drop 4 (prIdent cat)
+	  fs = map (prIdent . fst) rules
+
+isBaseFun :: VIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` prIdent f
+
+isConsFun :: VIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` prIdent f
+
+baseSize :: (VIdent, [(VIdent, [VIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (isBaseFun . fst) rules
+-}