diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs index 03965fba7..94d8e354a 100644 --- a/src/GF/Data/XML.hs +++ b/src/GF/Data/XML.hs @@ -12,7 +12,7 @@ module GF.Data.XML (XML(..), Attr, comments, showsXMLDoc, showsXML) where import GF.Data.Utilities -data XML = Data String | CData String | Tag String [Attr] [XML] | Comment String +data XML = Data String | CData String | Tag String [Attr] [XML] | Comment String | Empty deriving (Ord,Eq,Show) type Attr = (String,String) @@ -32,6 +32,7 @@ showsXML (Tag t as cs) = showChar '<' . showString t . showsAttrs as . showChar '>' . concatS (map showsXML cs) . showString "' showsXML (Comment c) = showString "" +showsXML (Empty) = id showsAttrs :: [Attr] -> ShowS showsAttrs = concatS . map (showChar ' ' .) . map showsAttr diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs index 20f42523a..a8c166791 100644 --- a/src/GF/Speech/PrSRGS.hs +++ b/src/GF/Speech/PrSRGS.hs @@ -5,20 +5,17 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- -- This module prints a CFG as an SRGS XML grammar. -- -- FIXME: remove \/ warn \/ fail if there are int \/ string literal -- categories in the grammar ----------------------------------------------------------------------------- -module GF.Speech.PrSRGS (srgsXmlPrinter) where +module GF.Speech.PrSRGS (SISRFormat(..), srgsXmlPrinter) where import GF.Data.Utilities import GF.Data.XML +import GF.Speech.SISR as SISR import GF.Speech.SRG import GF.Infra.Ident import GF.Today @@ -35,16 +32,17 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set + srgsXmlPrinter :: Ident -- ^ Grammar name -> String -- ^ Start category -> Options - -> Bool -- ^ Whether to include semantic interpretation + -> Maybe SISRFormat -> Maybe Probs -> CGrammar -> String srgsXmlPrinter name start opts sisr probs cfg = prSrgsXml sisr srg "" where srg = makeSRG name start opts probs cfg -prSrgsXml :: Bool -> SRG -> ShowS +prSrgsXml :: Maybe SISRFormat -> SRG -> ShowS prSrgsXml sisr (SRG{grammarName=name,startCat=start, origStartCat=origStart,grammarLanguage=l,rules=rs}) = showsXMLDoc xmlGr @@ -66,11 +64,11 @@ prSrgsXml sisr (SRG{grammarName=name,startCat=start, cs = sortNub [f | SRGAlt _ (Name f _) _ <- alts] prRhs isList rhss = [oneOf (map (mkProd sisr isList) rhss)] -- externally visible rules for each of the GF categories - topCatRules = [topRule tc [oneOf (map it cs)] | (tc,cs) <- topCats] + topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- topCats] where topCats = buildMultiMap [(cfgCatToGFCat origCat, cat) | SRGRule cat origCat _ <- rs] - it c = symItem [] (Cat c) 0 - topRule i is = Tag "rule" [("id",i),("scope","public")] - (is ++ [tag ["$."++i++ " = $$"]]) + it i c = Tag "item" [] [Tag "ruleref" [("uri","#" ++ prCat c)] [], + tag sisr [(EThis :. i) := (ERef c)]] + topRule i is = Tag "rule" [("id",i),("scope","public")] is rule :: String -> [XML] -> XML rule i = Tag "rule" [("id",i)] @@ -84,51 +82,49 @@ isBase f = "Base" `isPrefixOf` prIdent f isCons :: Fun -> Bool isCons f = "Cons" `isPrefixOf` prIdent f -mkProd :: Bool -> Bool -> SRGAlt -> XML +mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML mkProd sisr isList (SRGAlt p n@(Name f pr) rhs) - | sisr = prodItem (Just n) p (r ++ if isList then [buildList] else []) - | otherwise = prodItem Nothing p (map (\s -> symItem [] s 0) rhs) + = prodItem sisr n p (r ++ if isList then [tag sisr buildList] else []) where - r = map (uncurry (symItem pr)) (numberCats 0 rhs) - buildList | isBase f = - tag ["$ = new Array(" ++ join "," args ++ ")"] - | isCons f = tag ["$.arg1.unshift($.arg0); $ = $.arg1;"] - where args = ["$.arg"++show n | n <- [0..length pr-1]] + r = map (uncurry (symItem sisr pr)) (numberCats 0 rhs) + buildList | isBase f = [EThis := (ENew "Array" args)] + | isCons f = [EApp (EThis :. "arg1" :. "unshift") [EThis :. "arg0"], + EThis := (EThis :. "arg1")] + where args = [EThis :. ("arg"++show n) | n <- [0..length pr-1]] numberCats _ [] = [] numberCats n (s@(Cat _):ss) = (s,n):numberCats (n+1) ss numberCats n (s:ss) = (s,n):numberCats n ss -prodItem :: Maybe Name -> Maybe Double -> [XML] -> XML -prodItem n mp xs = Tag "item" w (t++cs) +prodItem :: Maybe SISRFormat -> Name -> Maybe Double -> [XML] -> XML +prodItem sisr n mp xs = Tag "item" w (t++cs) where w = maybe [] (\p -> [("weight", show p)]) mp - t = maybe [] prodTag n + t = prodTag sisr n cs = case xs of [Tag "item" [] xs'] -> xs' _ -> xs -prodTag :: Name -> [XML] -prodTag (Name f prs) = [tag ts] +prodTag :: Maybe SISRFormat -> Name -> [XML] +prodTag sisr (Name f prs) = [tag sisr ts] where - ts = ["$.name=" ++ showFun f] ++ - ["$.arg" ++ show n ++ "=" ++ argInit (prs!!n) + ts = [(EThis :. "name") := (EStr (prIdent f))] ++ + [(EThis :. ("arg" ++ show n)) := (EStr (argInit (prs!!n))) | n <- [0..length prs-1]] - argInit (Unify _) = metavar - argInit (Constant f) = maybe metavar showFun (forestName f) - showFun = show . prIdent - metavar = show "?" + argInit (Unify _) = "?" + argInit (Constant f) = maybe "?" prIdent (forestName f) -symItem :: [Profile a] -> Symbol String Token -> Int -> XML -symItem prs (Cat c) x = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t) +symItem :: Maybe SISRFormat -> [Profile a] -> Symbol String Token -> Int -> XML +symItem sisr prs (Cat c) x = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t) where - t = if null ts then [] else [tag ts] - ts = ["$.arg" ++ show n ++ "=$$" + t = if null ts then [] else [tag sisr ts] + ts = [(EThis :. ("arg" ++ show n)) := (ERef (prCat c)) | n <- [0..length prs-1], inProfile x (prs!!n)] -symItem _ (Tok t) _ = Tag "item" [] [Data (showToken t)] +symItem _ _ (Tok t) _ = Tag "item" [] [Data (showToken t)] -tag :: [String] -> XML -tag ts = Tag "tag" [] [Data (join "; " ts)] +tag :: Maybe SISRFormat -> [SISRExpr] -> XML +tag Nothing _ = Empty +tag (Just fmt) ts = Tag "tag" [] [Data (join "; " (map (prSISR fmt) ts))] inProfile :: Int -> Profile a -> Bool inProfile x (Unify xs) = x `elem` xs diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs new file mode 100644 index 000000000..15ab98027 --- /dev/null +++ b/src/GF/Speech/SISR.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.SISR +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- Abstract syntax and pretty printer for SISR, +-- (Semantic Interpretation for Speech Recognition) +-- +----------------------------------------------------------------------------- + +module GF.Speech.SISR (SISRFormat(..), SISRExpr(..), prSISR) where + +import Data.List + +infixl 8 :. +infixr 1 := + +data SISRFormat = SISROld + deriving Show + +data SISRExpr = SISRExpr := SISRExpr + | EThis + | SISRExpr :. String + | ERef String + | EStr String + | EApp SISRExpr [SISRExpr] + | ENew String [SISRExpr] + deriving Show + +prSISR :: SISRFormat -> SISRExpr -> String +prSISR fmt = f + where + f e = + case e of + x := y -> f x ++ "=" ++ f y + EThis -> "$" + x :. y -> f x ++ "." ++ y + ERef y -> "$" ++ y + EStr s -> show s + EApp x ys -> f x ++ "(" ++ concat (intersperse "," (map f ys)) ++ ")" + ENew n ys -> "new " ++ n ++ "(" ++ concat (intersperse "," (map f ys)) ++ ")" \ No newline at end of file diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 4aef4e33c..7e76688d9 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -61,7 +61,7 @@ import GF.Canon.MkGFC import GF.CF.CFtoSRG import GF.Speech.PrGSL (gslPrinter) import GF.Speech.PrJSGF (jsgfPrinter) -import GF.Speech.PrSRGS (srgsXmlPrinter) +import qualified GF.Speech.PrSRGS as SRGS import GF.Speech.PrSLF import GF.Speech.PrFA (faGraphvizPrinter,regularPrinter,faCPrinter) import GF.Speech.GrammarToVoiceXML (grammar2vxml) @@ -254,16 +254,16 @@ customGrammarPrinter = in jsgfPrinter name start opts Nothing $ stateCFG s) ,(strCI "srgs_xml", \opts s -> let name = cncId s start = getStartCatCF opts s - in srgsXmlPrinter name start opts False Nothing $ stateCFG s) + in SRGS.srgsXmlPrinter name start opts Nothing Nothing $ stateCFG s) ,(strCI "srgs_xml_prob", \opts s -> let name = cncId s probs = stateProbs s start = getStartCatCF opts s - in srgsXmlPrinter name start opts False (Just probs) $ stateCFG s) - ,(strCI "srgs_xml_ms_sem", + in SRGS.srgsXmlPrinter name start opts Nothing (Just probs) $ stateCFG s) + ,(strCI "srgs_xml_sisr_old", \opts s -> let name = cncId s start = getStartCatCF opts s - in srgsXmlPrinter name start opts True Nothing $ stateCFG s) + in SRGS.srgsXmlPrinter name start opts (Just SRGS.SISROld) Nothing $ stateCFG s) ,(strCI "vxml", \opts s -> let start = getStartCat opts s in grammar2vxml start s) ,(strCI "slf", \opts s -> let start = getStartCatCF opts s