gf-core/src/compiler/api/GF/Speech/VoiceXML.hs

----------------------------------------------------------------------
-- |
-- Module      : GF.Speech.VoiceXML
--
-- Creates VoiceXML dialogue systems from PGF grammars.
-----------------------------------------------------------------------------
module GF.Speech.VoiceXML (grammar2vxml) where

import GF.Data.XML
import PGF2
import Data.List (intersperse) -- isPrefixOf, find
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)

--import Debug.Trace

-- | the main function
grammar2vxml :: PGF -> Concr -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name mb_language start skel qs) ""
    where skel = pgfSkeleton pgf
          name = concreteName cnc
          qs = catQuestions cnc (map fst skel)
          mb_language = languageCode cnc
          (_,start,_) = unType (startCat pgf)

--
-- * VSkeleton: a simple description of the abstract syntax.
--

type Skeleton = [(Cat, [(Fun, [Cat])])]

pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]])
                     | c <- categories pgf]

--
-- * Questions to ask 
--

type CatQuestions = [(Cat,String)]

catQuestions :: Concr -> [Cat] -> CatQuestions
catQuestions cnc cats = [(c,catQuestion cnc c) | c <- cats]

catQuestion :: Concr -> Cat -> String
catQuestion cnc cat = fromMaybe cat (printName cnc cat)

getCatQuestion :: Cat -> CatQuestions -> String
getCatQuestion c qs = 
    fromMaybe (error "No question for category " ++ c) (lookup c qs)

--
-- * Generate VoiceXML
--

skel2vxml :: String -> Maybe String -> Cat -> Skeleton -> 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 -> Cat -> [(Fun, [Cat])] -> [XML]
catForms gr qs cat fs = 
    comments [cat ++ " category."]
    ++ [cat2form gr qs cat fs] 

cat2form :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> 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 -> Cat -> Fun -> [Cat] -> [XML]
fun2sub gr cat fun args = 
    comments [fun ++ " : (" 
              ++ concat (intersperse ", " args)
              ++ ") " ++ cat] ++ ss
  where 
  ss = zipWith mkSub [0..] args
  mkSub n t = subdialog s [("src","#"++catFormId t),
                           ("cond","term.name == "++string  fun)] 
              [param "old" v,
               filled [] [assign v (s++".term")]]
    where s = fun ++ "_" ++ show n
          v = "term.args["++show n++"]"

catFormId :: Cat -> String
catFormId c = 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
--
-- * ECMAScript stuff
--

string :: String -> String
string s = "'" ++ concatMap esc s ++ "'"
  where esc '\'' = "\\'"
        esc c    = [c]

{-
--
-- * List stuff
--

isListCat :: (CId, [(CId, [CId])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` showIdent cat && length rules == 2
		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
    where c = drop 4 (showIdent cat)
	  fs = map (showIdent . fst) rules

isBaseFun :: CId -> Bool
isBaseFun f = "Base" `isPrefixOf` showIdent f

isConsFun :: CId -> Bool
isConsFun f = "Cons" `isPrefixOf` showIdent f

baseSize :: (CId, [(CId, [CId])]) -> Int
baseSize (_,rules) = length bs
    where Just (_,bs) = find (isBaseFun . fst) rules
-}