diff --git a/src/GF/Speech/GrammarToVoiceXML.hs b/src/GF/Speech/GrammarToVoiceXML.hs index d7e916a72..5fbef29b6 100644 --- a/src/GF/Speech/GrammarToVoiceXML.hs +++ b/src/GF/Speech/GrammarToVoiceXML.hs @@ -11,27 +11,32 @@ module GF.Speech.GrammarToVoiceXML (grammar2vxml) where import qualified GF.Canon.GFC as GFC -import GF.Canon.CMacros (noMark) +import GF.Canon.AbsGFC (Term) +import GF.Canon.PrintGFC (printTree) +import GF.Canon.CMacros (noMark, strsFromTerm) import GF.Canon.Unlex (formatAsText) -import GF.Compile.ShellState (StateGrammar,stateGrammarST,cncId) -import GF.Grammar.Macros hiding (assign) +import GF.Compile.ShellState (StateGrammar,stateGrammarST,cncId,grammar) +import GF.Data.Str (sstrV) +import GF.Grammar.Macros hiding (assign,strsFromTerm) import GF.Grammar.Grammar (Fun) import GF.Grammar.Values (Tree) import GF.UseGrammar.GetTree (string2treeErr) import GF.UseGrammar.Linear (linTree2strings) +import GF.Infra.Ident import GF.Infra.Modules import GF.Data.Operations import GF.Data.XML +import Control.Monad (liftM) import Data.List (isPrefixOf, find, intersperse) import Data.Maybe (fromMaybe) import Debug.Trace -- | the main function -grammar2vxml :: String -> StateGrammar -> String +grammar2vxml :: Ident -> StateGrammar -> String grammar2vxml startcat gr = showsXMLDoc (skel2vxml name language startcat gr' qs) "" where (name, gr') = vSkeleton (stateGrammarST gr) qs = catQuestions gr (map fst gr') @@ -40,25 +45,23 @@ grammar2vxml startcat gr = showsXMLDoc (skel2vxml name language startcat gr' qs) -- * VSkeleton: a simple description of the abstract syntax. -- -type VIdent = String +type VSkeleton = [(Ident, [(Ident, [Ident])])] +type VIdent = Ident -type VSkeleton = [(VIdent, [(VIdent, [VIdent])])] - -vSkeleton :: GFC.CanonGrammar -> (String,VSkeleton) +vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton) vSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where collectR rr hh = case rr of (fun,typ):rs -> case catSkeleton typ of Ok (cats,cat) -> - collectR rs (updateSkeleton (symid (snd cat)) hh (fun, - map (symid . snd) cats)) + collectR rs (updateSkeleton (snd cat) hh (fun, map snd cats)) _ -> collectR rs hh _ -> hh - cats = [symid cat | (cat,GFC.AbsCat _ _) <- defs] - rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs] + cats = [cat | (cat,GFC.AbsCat _ _) <- defs] + rules = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs] defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] - name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m] + name = ifNull (error "No abstract module") last [n | (n,ModMod m) <- modules gr, isModAbs m] updateSkeleton :: VIdent -> VSkeleton -> (VIdent, [VIdent]) -> VSkeleton updateSkeleton cat skel rule = @@ -75,12 +78,23 @@ 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 (lin gr fun) - where fun = "quest_" ++ cat - errHandler e = trace ("GrammarToVoiceXML: " ++ e) fun - -- FIXME: use some better warning facility +catQuestion :: StateGrammar -> Ident -> String +catQuestion gr cat = err errHandler id (getPrintname gr cat >>= term2string) + where -- FIXME: use some better warning facility + errHandler e = trace ("GrammarToVoiceXML: " ++ e) ("quest_"++prIdent cat) + term2string = liftM sstrV . strsFromTerm +getPrintname :: StateGrammar -> Ident -> Err Term +getPrintname gr cat = + do m <- lookupModMod (grammar gr) (cncId gr) + i <- lookupInfo m cat + case i of + GFC.CncCat _ _ p -> return p + _ -> fail $ "getPrintname " ++ prIdent cat + ++ ": Expected CncCat, got " ++ show i + + +{- lin :: StateGrammar -> String -> Err String lin gr fun = do tree <- string2treeErr gr fun @@ -91,20 +105,21 @@ lin gr fun = do where c = cncId gr g = stateGrammarST gr unt = formatAsText +-} getCatQuestion :: VIdent -> CatQuestions -> String getCatQuestion c qs = - fromMaybe (error "No question for category " ++ c) (lookup c qs) + fromMaybe (error "No question for category " ++ prIdent c) (lookup c qs) -- -- * Generate VoiceXML -- -skel2vxml :: String -> String -> VIdent -> VSkeleton -> CatQuestions -> XML +skel2vxml :: VIdent -> String -> VIdent -> VSkeleton -> CatQuestions -> XML skel2vxml name language start skel qs = vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel) where - gr = grammarURI name + gr = grammarURI (prIdent name) startForm = Tag "form" [] [subdialog "sub" [("src", "#"++catFormId start)] []] grammarURI :: String -> String @@ -113,42 +128,58 @@ grammarURI name = name ++ ".grxml" catForms :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> [XML] catForms gr qs cat fs = - comments [cat ++ " category."] + comments [prIdent cat ++ " category."] ++ [cat2form gr qs cat fs] cat2form :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> XML cat2form gr qs cat fs = form (catFormId cat) $ [var "value" (Just "{ name : '?' }"), - var "update" Nothing, + var "callbacks" Nothing, blockCond "value.name != '?'" [assign (catFieldId cat) "value"], + block [doCallback "entered" cat [return_ [catFieldId cat]] []], field (catFieldId cat) [] [promptString (getCatQuestion cat qs), - grammar (gr++"#"++catFormId cat), + vxmlGrammar (gr++"#"++catFormId cat), nomatch [Data "I didn't understand you.", reprompt], - help [Data ("help_"++cat)], - filled [] [if_else (catFieldId cat ++ ".name == '?'") [reprompt] feedback]] + help [Data (mkHelpText cat)], + filled [] [if_else (catFieldId cat ++ ".name == '?'") + [reprompt] + [doCallback "refined" cat [return_ [catFieldId cat]] []]] + ] ] ++ concatMap (uncurry (fun2sub gr cat)) fs - ++ [block [return_ [catFieldId cat]]] - where feedback = [if_ ("typeof update != 'undefined' && !update("++string cat++","++ catFieldId cat ++ ")") [return_ [catFieldId cat]]] + ++ [block [doCallback "done" cat [return_ [catFieldId cat]] [return_ [catFieldId cat]]]] + +mkHelpText :: VIdent -> String +mkHelpText cat = "help_"++ prIdent cat fun2sub :: String -> VIdent -> VIdent -> [VIdent] -> [XML] -fun2sub gr cat fun args = comments [fun ++ " : (" ++ concat (intersperse ", " args) ++ ") " ++ cat] ++ ss +fun2sub gr cat fun args = + comments [prIdent fun ++ " : (" + ++ concat (intersperse ", " (map prIdent args)) + ++ ") " ++ prIdent cat] ++ ss where argNames = zip ["arg"++show n | n <- [0..]] args ss = map (uncurry mkSub) argNames - mkSub a t = subdialog s [("src","#"++catFormId t),("cond",catFieldId cat++".name == "++string fun)] + mkSub a t = subdialog s [("src","#"++catFormId t), + ("cond",catFieldId cat++".name == "++string (prIdent fun))] [param "value" (catFieldId cat++"."++a), - param "update" "update", + param "callbacks" "callbacks", filled [] [assign (catFieldId cat++"."++a) (s++"."++catFieldId t)]] - where s = fun ++ "_" ++ a + where s = prIdent fun ++ "_" ++ a + +doCallback :: String -> VIdent -> [XML] -> [XML] -> XML +doCallback f cat i e = + if_else ("callbacks && " ++ cf ++ " && !" ++ cf ++ "("++string (prIdent cat)++","++ catFieldId cat ++ ")") + i e + where cf = "callbacks." ++ f catFormId :: VIdent -> String -catFormId = (++ "_cat") +catFormId c = prIdent c ++ "_cat" catFieldId :: VIdent -> String -catFieldId = (++ "_field") +catFieldId c = prIdent c ++ "_field" -- -- * VoiceXML stuff @@ -171,8 +202,8 @@ subdialog name attrs = Tag "subdialog" ([("name",name)]++attrs) filled :: [(String,String)] -> [XML] -> XML filled = Tag "filled" -grammar :: String -> XML -grammar uri = Tag "grammar" [("src",uri)] [] +vxmlGrammar :: String -> XML +vxmlGrammar uri = Tag "grammar" [("src",uri)] [] prompt :: [XML] -> XML prompt = Tag "prompt" [] @@ -243,26 +274,24 @@ string s = "'" ++ concatMap esc s ++ "'" where esc '\'' = "\\'" esc c = [c] +{- -- -- * List stuff -- isListCat :: (VIdent, [(VIdent, [VIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 +isListCat (cat,rules) = "List" `isPrefixOf` prIdent cat && length rules == 2 && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: VIdent -> VIdent -elemCat = drop 4 + where c = drop 4 (prIdent cat) + fs = map (prIdent . fst) rules isBaseFun :: VIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f +isBaseFun f = "Base" `isPrefixOf` prIdent f isConsFun :: VIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f +isConsFun f = "Cons" `isPrefixOf` prIdent f baseSize :: (VIdent, [(VIdent, [VIdent])]) -> Int baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules + where Just (_,bs) = find (isBaseFun . fst) rules +-} \ No newline at end of file diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 9a689cb8c..4fdc04982 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -270,7 +270,7 @@ customGrammarPrinter = \opts s -> let name = cncId s start = getStartCatCF opts s in SRGS.srgsXmlPrinter name start opts (Just SISR.SISROld) Nothing $ stateCFG s) - ,(strCI "vxml", \opts s -> let start = getStartCat opts s + ,(strCI "vxml", \opts s -> let start = cfCat2Ident (startCatStateOpts opts s) in grammar2vxml start s) ,(strCI "slf", \opts s -> let start = getStartCatCF opts s name = cncId s