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