Changed SRGS SISR printing to be closer to the current working draft standard, as supported by the WebSphere implementation (and thus Opera).

4 files changed, 83 insertions, 43 deletions

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 "</" . showString t . showChar '>'
 showsXML (Comment c) = showString "<!-- " . showString 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