----------------------------------------------------------------------
-- |
-- 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 PGF
import PGF.Internal

--import Control.Monad (liftM)
import Data.List (intersperse) -- isPrefixOf, find
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)

--import Debug.Trace

-- | the main function
grammar2vxml :: PGF -> CId -> String
grammar2vxml :: PGF -> CId -> String
grammar2vxml PGF
pgf CId
cnc = XML -> ShowS
showsXMLDoc (String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
skel2vxml String
name Maybe String
language CId
start Skeleton
skel CatQuestions
qs) String
""
    where skel :: Skeleton
skel = PGF -> Skeleton
pgfSkeleton PGF
pgf
          name :: String
name = CId -> String
showCId CId
cnc
          qs :: CatQuestions
qs = PGF -> CId -> [CId] -> CatQuestions
catQuestions PGF
pgf CId
cnc (((CId, [(CId, [CId])]) -> CId) -> Skeleton -> [CId]
forall a b. (a -> b) -> [a] -> [b]
map (CId, [(CId, [CId])]) -> CId
forall a b. (a, b) -> a
fst Skeleton
skel)
          language :: Maybe String
language = PGF -> CId -> Maybe String
languageCode PGF
pgf CId
cnc
          start :: CId
start = PGF -> CId
lookStartCat PGF
pgf

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

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

pgfSkeleton :: PGF -> Skeleton
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton PGF
pgf = [(CId
c,[(CId
f,([CId], CId) -> [CId]
forall a b. (a, b) -> a
fst (Type -> ([CId], CId)
catSkeleton (Abstr -> CId -> Type
lookType (PGF -> Abstr
abstract PGF
pgf) CId
f))) | (Double
_,CId
f) <- [(Double, CId)]
fs]) 
                   | (CId
c,([Hypo]
_,[(Double, CId)]
fs,Double
_)) <- Map CId ([Hypo], [(Double, CId)], Double)
-> [(CId, ([Hypo], [(Double, CId)], Double))]
forall k a. Map k a -> [(k, a)]
Map.toList (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
pgf))]

--
-- * Questions to ask 
--

type CatQuestions = [(CId,String)]

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

catQuestion :: PGF -> CId -> CId -> String
catQuestion :: PGF -> CId -> CId -> String
catQuestion PGF
pgf CId
cnc CId
cat = PGF -> CId -> CId -> String
showPrintName PGF
pgf CId
cnc CId
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 :: CId -> CatQuestions -> String
getCatQuestion CId
c CatQuestions
qs = 
    String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
"No question for category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CId -> String
showCId CId
c) (CId -> CatQuestions -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CId
c CatQuestions
qs)

--
-- * Generate VoiceXML
--

skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
skel2vxml String
name Maybe String
language CId
start Skeleton
skel CatQuestions
qs = 
    Maybe String -> [XML] -> XML
vxml Maybe String
language ([XML
startForm] [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ ((CId, [(CId, [CId])]) -> [XML]) -> Skeleton -> [XML]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CId -> [(CId, [CId])] -> [XML]) -> (CId, [(CId, [CId])]) -> [XML]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms String
gr CatQuestions
qs)) Skeleton
skel)
  where 
  gr :: String
gr = ShowS
grammarURI String
name
  startForm :: XML
startForm = String -> [Attr] -> [XML] -> XML
Tag String
"form" [] [String -> [Attr] -> [XML] -> XML
subdialog String
"sub" [(String
"src", String
"#"String -> ShowS
forall a. [a] -> [a] -> [a]
++CId -> String
catFormId CId
start)] 
                                           [String -> String -> XML
param String
"old" String
"{ name : '?' }"]]

grammarURI :: String -> String
grammarURI :: ShowS
grammarURI String
name = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".grxml"


catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms String
gr CatQuestions
qs CId
cat [(CId, [CId])]
fs = 
    [String] -> [XML]
comments [CId -> String
showCId CId
cat String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" category."]
    [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
cat2form String
gr CatQuestions
qs CId
cat [(CId, [CId])]
fs] 

cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
cat2form String
gr CatQuestions
qs CId
cat [(CId, [CId])]
fs = 
  String -> [XML] -> XML
form (CId -> String
catFormId CId
cat) ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ 
      [String -> Maybe String -> XML
var String
"old" Maybe String
forall a. Maybe a
Nothing, 
       String -> [XML] -> XML
blockCond String
"old.name != '?'" [String -> String -> XML
assign String
"term" String
"old"],
       String -> [Attr] -> [XML] -> XML
field String
"term" []
           [String -> XML
promptString (CId -> CatQuestions -> String
getCatQuestion CId
cat CatQuestions
qs), 
            String -> XML
vxmlGrammar (String
grString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"#"String -> ShowS
forall a. [a] -> [a] -> [a]
++CId -> String
catFormId CId
cat)
           ]
      ]
     [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ ((CId, [CId]) -> [XML]) -> [(CId, [CId])] -> [XML]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CId -> [CId] -> [XML]) -> (CId, [CId]) -> [XML]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> CId -> CId -> [CId] -> [XML]
fun2sub String
gr CId
cat)) [(CId, [CId])]
fs
     [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [[XML] -> XML
block [[String] -> XML
return_ [String
"term"]{-]-}]]

fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub String
gr CId
cat CId
fun [CId]
args = 
    [String] -> [XML]
comments [CId -> String
showCId CId
fun String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : (" 
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ((CId -> String) -> [CId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CId -> String
showCId [CId]
args))
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CId -> String
showCId CId
cat] [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [XML]
ss
  where 
  ss :: [XML]
ss = (Integer -> CId -> XML) -> [Integer] -> [CId] -> [XML]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> CId -> XML
forall a. Show a => a -> CId -> XML
mkSub [Integer
0..] [CId]
args
  mkSub :: a -> CId -> XML
mkSub a
n CId
t = String -> [Attr] -> [XML] -> XML
subdialog String
s [(String
"src",String
"#"String -> ShowS
forall a. [a] -> [a] -> [a]
++CId -> String
catFormId CId
t),
                           (String
"cond",String
"term.name == "String -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
string (CId -> String
showCId CId
fun))] 
              [String -> String -> XML
param String
"old" String
v,
               [Attr] -> [XML] -> XML
filled [] [String -> String -> XML
assign String
v (String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
".term")]]
    where s :: String
s = CId -> String
showCId CId
fun String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
          v :: String
v = String
"term.args["String -> ShowS
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
nString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"]"

catFormId :: CId -> String
catFormId :: CId -> String
catFormId CId
c = CId -> String
showCId CId
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_cat"


--
-- * VoiceXML stuff
--

vxml :: Maybe String -> [XML] -> XML
vxml :: Maybe String -> [XML] -> XML
vxml Maybe String
ml = String -> [Attr] -> [XML] -> XML
Tag String
"vxml" ([Attr] -> [XML] -> XML) -> [Attr] -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ [(String
"version",String
"2.0"),
                        (String
"xmlns",String
"http://www.w3.org/2001/vxml")]
                      [Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ [Attr] -> (String -> [Attr]) -> Maybe String -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
l -> [(String
"xml:lang", String
l)]) Maybe String
ml

form :: String -> [XML] -> XML
form :: String -> [XML] -> XML
form String
id [XML]
xs = String -> [Attr] -> [XML] -> XML
Tag String
"form" [(String
"id", String
id)] [XML]
xs

field :: String -> [(String,String)] -> [XML] -> XML
field :: String -> [Attr] -> [XML] -> XML
field String
name [Attr]
attrs = String -> [Attr] -> [XML] -> XML
Tag String
"field" ([(String
"name",String
name)][Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++[Attr]
attrs)

subdialog :: String -> [(String,String)] -> [XML] -> XML
subdialog :: String -> [Attr] -> [XML] -> XML
subdialog String
name [Attr]
attrs = String -> [Attr] -> [XML] -> XML
Tag String
"subdialog" ([(String
"name",String
name)][Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++[Attr]
attrs)

filled :: [(String,String)] -> [XML] -> XML
filled :: [Attr] -> [XML] -> XML
filled = String -> [Attr] -> [XML] -> XML
Tag String
"filled"

vxmlGrammar :: String -> XML
vxmlGrammar :: String -> XML
vxmlGrammar String
uri = String -> [Attr] -> XML
ETag String
"grammar" [(String
"src",String
uri)]

prompt :: [XML] -> XML
prompt :: [XML] -> XML
prompt = String -> [Attr] -> [XML] -> XML
Tag String
"prompt" []

promptString :: String -> XML
promptString :: String -> XML
promptString String
p = [XML] -> XML
prompt [String -> XML
Data String
p]
{-
reprompt :: XML
reprompt = ETag "reprompt" []
-}
assign :: String -> String -> XML
assign :: String -> String -> XML
assign String
n String
e = String -> [Attr] -> XML
ETag String
"assign" [(String
"name",String
n),(String
"expr",String
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_ :: [String] -> XML
return_ [String]
names = String -> [Attr] -> XML
ETag String
"return" [(String
"namelist", [String] -> String
unwords [String]
names)]

block :: [XML] -> XML
block :: [XML] -> XML
block = String -> [Attr] -> [XML] -> XML
Tag String
"block" []

blockCond :: String -> [XML] -> XML
blockCond :: String -> [XML] -> XML
blockCond String
cond = String -> [Attr] -> [XML] -> XML
Tag String
"block" [(String
"cond", String
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 :: String -> String -> XML
param String
name String
expr = String -> [Attr] -> XML
ETag String
"param" [(String
"name",String
name),(String
"expr",String
expr)]

var :: String -> Maybe String -> XML
var :: String -> Maybe String -> XML
var String
name Maybe String
expr = String -> [Attr] -> XML
ETag String
"var" ([(String
"name",String
name)][Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++[Attr]
e)
  where e :: [Attr]
e = [Attr] -> (String -> [Attr]) -> Maybe String -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
:[]) (Attr -> [Attr]) -> (String -> Attr) -> String -> [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) String
"expr") Maybe String
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 :: ShowS
string String
s = String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
esc String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
  where esc :: Char -> String
esc Char
'\'' = String
"\\'"
        esc Char
c    = [Char
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
-}