Moved general XML stuff to GF.Data.XML. Started working on VoiceXML generation.

src/GF/Data/XML.hs

@@ -0,0 +1,46 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : XML
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Utilities for creating XML documents.
+-----------------------------------------------------------------------------
+
+module GF.Data.XML (XML(..), Attr, comments, showsXMLDoc, showsXML) where
+
+import GF.Data.Utilities
+
+data XML = Data String | Tag String [Attr] [XML] | Comment String
+ deriving (Eq,Show)
+
+type Attr = (String,String)
+
+comments :: [String] -> [XML]
+comments = map Comment
+
+showsXMLDoc :: XML -> ShowS
+showsXMLDoc xml = showString header . showsXML xml 
+  where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
+
+showsXML :: XML -> ShowS
+showsXML (Data s) = showString s
+showsXML (Tag t as []) = showChar '<' . showString t . showsAttrs as . showString "/>"
+showsXML (Tag t as cs) = 
+    showChar '<' . showString t . showsAttrs as . showChar '>' 
+		 . concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
+showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
+
+showsAttrs :: [Attr] -> ShowS
+showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
+
+showsAttr :: Attr -> ShowS
+showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
+
+-- FIXME: escape strange charachters with &#xxx;
+escape :: String -> String
+escape = concatMap escChar
+  where
+  escChar c | c `elem` ['"','\\'] = '\\':[c]
+            | otherwise = [c]

src/GF/Shell/HelpFile.hs

@@ -600,6 +600,7 @@ txtHelpFile =
   "\n    -printer=srgs_xml_prob  SRGS XML format, with weights" ++
   "\n    -printer=srgs_xml_ms_sem SRGS XML format, with semantic tags for the" ++
   "\n                             Microsoft Speech API." ++
+  "\n    -printer=vxml           Generate a dialogue system in VoiceXML." ++
   "\n    -printer=slf            a finite automaton in the HTK SLF format" ++
   "\n    -printer=slf_graphviz   the same automaton as slf, but in Graphviz format" ++
   "\n    -printer=slf_sub        a finite automaton with sub-automata in the " ++

src/GF/Speech/GrammarToVoiceXML.hs

@@ -0,0 +1,195 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToVoiceXML
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Create VoiceXML dialogue system from a GF grammar.
+-----------------------------------------------------------------------------
+
+module GF.Speech.GrammarToVoiceXML (grammar2vxml) where
+
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Macros hiding (assign)
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import GF.Data.XML
+
+import Data.List (isPrefixOf, find, intersperse)
+
+-- | the main function
+grammar2vxml :: GFC.CanonGrammar -> String
+grammar2vxml gr = showsXMLDoc (skel2vxml name startcat gr') ""
+    where (name, gr') = vSkeleton gr
+          startcat = "Order" -- FIXME
+
+type VIdent = String
+
+type VSkeleton = [(VIdent, [(VIdent, [VIdent])])]
+
+
+vSkeleton :: GFC.CanonGrammar -> (String,VSkeleton)
+vSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
+  collectR rr hh =
+   case rr of
+     (fun,typ):rs -> case catSkeleton typ of
+        Ok (cats,cat) -> 
+             collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
+	                                                    map (symid . snd) cats))
+        _ -> collectR rs hh
+     _ -> hh
+  cats =  [symid cat | (cat,GFC.AbsCat _ _) <- defs]
+  rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+
+updateSkeleton :: VIdent -> VSkeleton -> (VIdent, [VIdent]) -> VSkeleton
+updateSkeleton cat skel rule =
+ case skel of
+   (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
+   (cat0,rules):rr               -> (cat0, rules) : updateSkeleton cat rr rule
+
+
+skel2vxml :: String -> VIdent -> VSkeleton -> XML
+skel2vxml name start skel = 
+    vxml ([startForm] ++ concatMap (uncurry (catForms gr)) skel)
+  where 
+  gr = grammarURI name
+  startForm = Tag "form" [] [subdialog "sub" [("src","#"++start)] []]
+
+grammarURI :: String -> String
+grammarURI name = name ++ ".grxml"
+
+catForms :: String -> VIdent -> [(VIdent, [VIdent])] -> [XML]
+catForms gr cat fs = 
+    comments [cat ++ " category."]
+    ++ [cat2form gr cat fs] 
+    ++ map (uncurry (fun2form gr)) fs
+
+cat2form :: String -> VIdent -> [(VIdent, [VIdent])] -> XML
+cat2form gr cat fs = 
+    form cat [var "value" (Just "'?'"),
+              field cat [] [promptString ("quest_"++cat), 
+                            grammar (gr++"#"++cat),
+                            nomatch [Data "I didn't understand you.", reprompt],
+                            help [Data ("help_"++cat)],
+                            filled [] [if_else (cat ++ " == '?'") [reprompt] feedback]],
+              subdialog "sub" [("srcexpr","'#'+"++cat++".name")] 
+                             [param "value" cat, filled [] subDone]]
+  where subDone = [return_ ["sub.value"]]
+        feedback = [Data "Constructor: ", value (cat++".name")]
+
+fun2form :: String -> VIdent -> [VIdent] -> XML
+fun2form gr fun args = 
+    form fun ([var "value" Nothing]
+              ++ ss
+              ++ [ret])
+  where 
+  argNames = zip ["arg"++show n | n <- [0..]] args
+  ss = map (uncurry mkSub) argNames
+  mkSub a t = subdialog a [("src","#"++t)] 
+                [param "value" ("value."++a),
+                 filled [] [assign ("value."++a) a]]
+  ret = block [return_ ["value"]]
+
+--
+-- * VoiceXML stuff
+--
+
+vxml :: [XML] -> XML
+vxml = Tag "vxml" [("version","2.0"),("xmlns","http://www.w3.org/2001/vxml")]
+
+form :: String -> [XML] -> XML
+form id = Tag "form" [("id", id)]
+
+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"
+
+grammar :: String -> XML
+grammar uri = Tag "grammar" [("src",uri)] []
+
+prompt :: [XML] -> XML
+prompt = Tag "prompt" []
+
+promptString :: String -> XML
+promptString p = prompt [Data p]
+
+reprompt :: XML
+reprompt = Tag "reprompt" [] []
+
+assign :: String -> String -> XML
+assign n e = Tag "assign" [("name",n),("expr",e)] []
+
+value :: String -> XML
+value expr = Tag "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 = Tag "goto" [("nextitem",nextitem)] []
+
+return_ :: [String] -> XML
+return_ names = Tag "return" [("namelist", unwords names)] []
+
+block :: [XML] -> XML
+block = Tag "block" []
+
+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 = Tag "param" [("name",name),("expr",expr)] []
+
+var :: String -> Maybe String -> XML
+var name expr = Tag "var" ([("name",name)]++e) []
+  where e = maybe [] ((:[]) . (,) "expr") expr
+
+
+--
+-- * List stuff
+--
+
+isListCat :: (VIdent, [(VIdent, [VIdent])]) -> Bool
+isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
+		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where c = elemCat cat
+	  fs = map fst rules
+
+-- | Gets the element category of a list category.
+elemCat :: VIdent -> VIdent
+elemCat = drop 4
+
+isBaseFun :: VIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` f
+
+isConsFun :: VIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` f
+
+baseSize :: (VIdent, [(VIdent, [VIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules

src/GF/Speech/PrSRGS.hs

@@ -18,6 +18,7 @@
 module GF.Speech.PrSRGS (srgsXmlPrinter) where
 
 import GF.Data.Utilities
+import GF.Data.XML
 import GF.Speech.SRG
 import GF.Infra.Ident
 import GF.Today
@@ -32,11 +33,6 @@ import GF.Probabilistic.Probabilistic (Probs)
 import Data.Char (toUpper,toLower)
 import Data.List
 
-data XML = Data String | Tag String [Attr] [XML] | Comment String
- deriving (Eq,Show)
-
-type Attr = (String,String)
-
 srgsXmlPrinter :: Ident -- ^ Grammar name
 	       -> Options 
                -> Bool  -- ^ Whether to include semantic interpretation 
@@ -48,9 +44,8 @@ srgsXmlPrinter name opts sisr probs cfg = prSrgsXml sisr srg ""
 prSrgsXml :: Bool -> SRG -> ShowS
 prSrgsXml sisr (SRG{grammarName=name,startCat=start,
                origStartCat=origStart,grammarLanguage=l,rules=rs})
-    = header . showsXML xmlGr
+    = showsXMLDoc xmlGr
     where
-    header = showString "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
     root = prCat start
     xmlGr = grammar root l ([meta "description" 
                              ("SRGS XML speech recognition grammar for " ++ name
@@ -67,15 +62,17 @@ prSrgsXml sisr (SRG{grammarName=name,startCat=start,
     prRhs isList rhss = [oneOf (map (mkProd sisr isList) rhss)] 
     -- externally visible rules for each of the GF categories
     topCatRules = [topRule tc [oneOf (map it cs)] | (tc,cs) <- topCats]
-        where topCats = buildMultiMap [(gfCat origCat, cat) | SRGRule cat origCat _ <- rs]
+        where topCats = buildMultiMap [(cfgCatToGFCat origCat, cat) | SRGRule cat origCat _ <- rs]
-              gfCat = takeWhile (/='{')
               it c = symItem [] (Cat c) 0
               topRule i is = Tag "rule" [("id",i),("scope","public")] 
-                             (is ++ [tag ["$ = $$"]])
+                             (is ++ [tag ["$."++i++ " = $$"]])
 
 rule :: String -> [XML] -> XML
 rule i = Tag "rule" [("id",i)]
 
+cfgCatToGFCat :: String -> String
+cfgCatToGFCat = takeWhile (/='{')
+
 isBase :: Fun -> Bool
 isBase f = "Base" `isPrefixOf` prIdent f
 
@@ -153,27 +150,3 @@ grammar root l = Tag "grammar" [("xml:lang", l),
 
 meta :: String -> String -> XML
 meta n c = Tag "meta" [("name",n),("content",c)] []
-
-comments :: [String] -> [XML]
-comments = map Comment
-
-showsXML :: XML -> ShowS
-showsXML (Data s) = showString s
-showsXML (Tag t as []) = showChar '<' . showString t . showsAttrs as . showString "/>"
-showsXML (Tag t as cs) = 
-    showChar '<' . showString t . showsAttrs as . showChar '>' 
-		 . concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
-showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
-
-showsAttrs :: [Attr] -> ShowS
-showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
-
-showsAttr :: Attr -> ShowS
-showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
-
--- FIXME: escape strange charachters with &#xxx;
-escape :: String -> String
-escape = concatMap escChar
-  where
-  escChar c | c `elem` ['"','\\'] = '\\':[c]
-            | otherwise = [c]

src/GF/UseGrammar/Custom.hs

@@ -60,6 +60,7 @@ import GF.Speech.PrJSGF (jsgfPrinter)
 import GF.Speech.PrSRGS (srgsXmlPrinter)
 import GF.Speech.PrSLF
 import GF.Speech.PrFA (faGraphvizPrinter,regularPrinter,faCPrinter)
+import GF.Speech.GrammarToVoiceXML (grammar2vxml)
 
 import GF.Data.Zipper
 
@@ -257,6 +258,7 @@ customGrammarPrinter =
   ,(strCI "srgs_xml_ms_sem", \s -> let opts = stateOptions s
                                        name = cncId s
                                    in srgsXmlPrinter name opts True Nothing $ stateCFG s)
+  ,(strCI "vxml",    grammar2vxml . stateGrammarST)
   ,(strCI "slf",     \s -> let opts = stateOptions s
                                start = getStartCat opts
                                name = cncId s

src/HelpFile

@@ -571,6 +571,7 @@ q, quit: q
     -printer=srgs_xml_prob  SRGS XML format, with weights
     -printer=srgs_xml_ms_sem SRGS XML format, with semantic tags for the
                              Microsoft Speech API.
+    -printer=vxml           Generate a dialogue system in VoiceXML.
     -printer=slf            a finite automaton in the HTK SLF format
     -printer=slf_graphviz   the same automaton as slf, but in Graphviz format
     -printer=slf_sub        a finite automaton with sub-automata in the