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

import GF.Data.Operations
import GF.Data.Str (sstrV)
import GF.Data.Utilities
import GF.Data.XML
import GF.Infra.Ident
import GF.Infra.Modules
import PGF
import PGF.Data
import PGF.Macros

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 :: PGF -> CId -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
    where skel = pgfSkeleton pgf
          name = showCId cnc
          qs = catQuestions pgf cnc (map fst skel)
          language = languageCode pgf cnc
          start = lookStartCat pgf

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

type Skeleton = [(CId, [(CId, [CId])])]

pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs]) 
                   | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]

--
-- * Questions to ask 
--

type CatQuestions = [(CId,String)]

catQuestions :: PGF -> CId -> [CId] -> CatQuestions
catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats]

catQuestion :: PGF -> CId -> CId -> String
catQuestion pgf cnc cat = showPrintName pgf cnc cat


{-
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 :: CId -> CatQuestions -> String
getCatQuestion c qs = 
    fromMaybe (error "No question for category " ++ showCId c) (lookup c qs)

--
-- * Generate VoiceXML
--

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

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

catFormId :: CId -> String
catFormId c = showCId 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 :: (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
-}