path: root/src/GF/Speech/GrammarToVoiceXML.hs

----------------------------------------------------------------------
-- |
-- 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
-}