diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs index e0ad08705..74d3ef81e 100644 --- a/src/GF/Data/Utilities.hs +++ b/src/GF/Data/Utilities.hs @@ -104,6 +104,10 @@ buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])] buildMultiMap = map (\g -> (fst (head g), map snd g) ) . sortGroupBy (compareBy fst) +-- | Replace all occurences of an element by another element. +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) + -- * equality functions -- | Use an ordering function as an equality predicate. diff --git a/src/GF/Speech/GrammarToVoiceXML.hs b/src/GF/Speech/GrammarToVoiceXML.hs index 961f021f5..b48af5a57 100644 --- a/src/GF/Speech/GrammarToVoiceXML.hs +++ b/src/GF/Speech/GrammarToVoiceXML.hs @@ -21,12 +21,13 @@ 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) +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) +import GF.Infra.Option (Options, addOptions, getOptVal, speechLanguage) import GF.UseGrammar.GetTree (string2treeErr) import GF.UseGrammar.Linear (linTree2strings) @@ -45,10 +46,11 @@ import Debug.Trace -- | the main function grammar2vxml :: Options -> StateGrammar -> String -grammar2vxml opts s = showsXMLDoc (skel2vxml name language startcat gr' qs) "" +grammar2vxml opt s = showsXMLDoc (skel2vxml name language startcat gr' qs) "" where (name, gr') = vSkeleton (stateGrammarST s) qs = catQuestions s (map fst gr') - language = "en" -- FIXME: use speechLanguage tag + opts = addOptions opt (stateOptions s) + language = fmap (replace '_' '-') $ getOptVal opts speechLanguage startcat = C.CId $ prIdent $ cfCat2Ident $ startCatStateOpts opts s -- @@ -117,7 +119,7 @@ getCatQuestion c qs = -- * Generate VoiceXML -- -skel2vxml :: VIdent -> String -> VIdent -> VSkeleton -> CatQuestions -> XML +skel2vxml :: VIdent -> Maybe String -> VIdent -> VSkeleton -> CatQuestions -> XML skel2vxml name language start skel qs = vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel) where @@ -169,10 +171,10 @@ catFormId c = prid c ++ "_cat" -- * VoiceXML stuff -- -vxml :: String -> [XML] -> XML -vxml language = Tag "vxml" [("version","2.0"), - ("xmlns","http://www.w3.org/2001/vxml"), - ("xml:lang", language)] +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 diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs index 8b12443a0..f6f0b19b2 100644 --- a/src/GF/Speech/PrJSGF.hs +++ b/src/GF/Speech/PrJSGF.hs @@ -34,6 +34,7 @@ import GF.Compile.ShellState (StateGrammar) import Data.Char import Data.List +import Data.Maybe import Text.PrettyPrint.HughesPJ import Debug.Trace @@ -44,13 +45,15 @@ jsgfPrinter :: Maybe SISRFormat jsgfPrinter sisr opts s = show $ prJSGF sisr $ makeSimpleSRG opts s prJSGF :: Maybe SISRFormat -> SRG -> Doc -prJSGF sisr srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) +prJSGF sisr srg@(SRG{grammarName=name,grammarLanguage=ml, + startCat=start,origStartCat=origStart,rules=rs}) = header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs) where - header = text "#JSGF V1.0 UTF-8;" $$ + header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$ comment ("JSGF speech recognition grammar for " ++ name) $$ comment "Generated by GF" $$ text ("grammar " ++ name ++ ";") + lang = maybe empty text ml mainCat = comment ("Start category: " ++ origStart) $$ rule True "MAIN" [prCat start] prRule (SRGRule cat origCat rhs) = diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs index e0754f389..b6af82d32 100644 --- a/src/GF/Speech/PrSRGS.hs +++ b/src/GF/Speech/PrSRGS.hs @@ -125,15 +125,15 @@ oneOf = Tag "one-of" [] grammar :: Maybe SISRFormat -> String -- ^ root - -> String -- ^language + -> Maybe String -- ^language -> [XML] -> XML -grammar sisr root l = - Tag "grammar" $ [("xml:lang", l), - ("xmlns","http://www.w3.org/2001/06/grammar"), +grammar sisr root ml = + Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), ("version","1.0"), ("mode","voice"), ("root",root)] ++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) + ++ maybe [] (\l -> [("xml:lang", l)]) ml meta :: String -> String -> XML meta n c = Tag "meta" [("name",n),("content",c)] [] diff --git a/src/GF/Speech/PrSRGS_ABNF.hs b/src/GF/Speech/PrSRGS_ABNF.hs index 2b965e9cb..d79ee7b55 100644 --- a/src/GF/Speech/PrSRGS_ABNF.hs +++ b/src/GF/Speech/PrSRGS_ABNF.hs @@ -47,7 +47,7 @@ srgsAbnfPrinter :: Maybe SISRFormat srgsAbnfPrinter sisr probs opts s = show $ prABNF sisr probs $ makeSimpleSRG opts s prABNF :: Maybe SISRFormat -> Bool -> SRG -> Doc -prABNF sisr probs srg@(SRG{grammarName=name,grammarLanguage = l, +prABNF sisr probs srg@(SRG{grammarName=name,grammarLanguage=ml, startCat=start,origStartCat=origStart,rules=rs}) = header $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs) where @@ -57,7 +57,7 @@ prABNF sisr probs srg@(SRG{grammarName=name,grammarLanguage = l, ++ ". " ++ "Original start category: " ++ origStart) $$ meta "generator" ("Grammatical Framework " ++ version) $$ language $$ tagFormat $$ mainCat - language = text "language" <+> text l <> char ';' + language = maybe empty (\l -> text "language" <+> text l <> char ';') ml tagFormat | isJust sisr = text "tag-format" <+> text "" <> char ';' | otherwise = empty mainCat = text "root" <+> prCat start <> char ';' diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index e0a347480..20bdd4a41 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -42,7 +42,7 @@ import GF.Speech.FiniteState import GF.Speech.RegExp import GF.Infra.Option import GF.Probabilistic.Probabilistic (Probs) -import GF.Compile.ShellState (StateGrammar, stateProbs, cncId) +import GF.Compile.ShellState (StateGrammar, stateProbs, stateOptions, cncId) import Data.List import Data.Maybe (fromMaybe, maybeToList) @@ -54,8 +54,8 @@ import qualified Data.Set as Set data SRG = SRG { grammarName :: String -- ^ grammar name , startCat :: String -- ^ start category name , origStartCat :: String -- ^ original start category name - , grammarLanguage :: String -- ^ The language for which the grammar - -- is intended, e.g. en_UK + , grammarLanguage :: Maybe String -- ^ The language for which the grammar + -- is intended, e.g. en-UK , rules :: [SRGRule] } deriving (Eq,Show) @@ -100,17 +100,18 @@ makeSRG_ :: (CFRules -> CFRules) -> Options -- ^ Grammar options -> StateGrammar -> SRG -makeSRG_ preprocess opts s = +makeSRG_ preprocess opt s = SRG { grammarName = name, startCat = lookupFM_ names origStart, origStartCat = origStart, grammarLanguage = l, rules = rs } where + opts = addOptions opt (stateOptions s) name = prIdent (cncId s) origStart = getStartCatCF opts s probs = stateProbs s - l = fromMaybe "en_UK" (getOptVal opts speechLanguage) + l = fmap (replace '_' '-') $ getOptVal opts speechLanguage (cats,cfgRules) = unzip $ preprocess $ cfgToCFRules s names = mkCatNames name cats rs = map (cfgRulesToSRGRule names probs) cfgRules