First version of SRGS with semantic tags.

src/GF/Speech/PrSRGS.hs

@@ -22,7 +22,7 @@ import GF.Speech.SRG
 import GF.Infra.Ident
 
 import GF.Formalism.CFG
-import GF.Formalism.Utilities (Symbol(..))
+import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName)
 import GF.Conversion.Types
 import GF.Infra.Print
 import GF.Infra.Option
@@ -37,43 +37,74 @@ type Attr = (String,String)
 
 srgsXmlPrinter :: Ident -- ^ Grammar name
 	       -> Options 
+               -> Bool  -- ^ Whether to include semantic interpretation 
 	       -> Maybe Probs
 	       -> CGrammar -> String
-srgsXmlPrinter name opts probs cfg = prSrgsXml srg ""
+srgsXmlPrinter name opts sisr probs cfg = prSrgsXml sisr srg ""
     where srg = makeSRG name opts probs cfg
 
-prSrgsXml :: SRG -> ShowS
-prSrgsXml (SRG{grammarName=name,startCat=start,
+prSrgsXml :: Bool -> SRG -> ShowS
+prSrgsXml sisr (SRG{grammarName=name,startCat=start,
                origStartCat=origStart,grammarLanguage=l,rules=rs})
     = header . showsXML xmlGr
     where
     header = showString "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
     root = prCat start
-    xmlGr = grammar root l (comments 
-			  ["SRGS XML speech recognition grammar for " ++ name,
-			   "Generated by GF",
-			   "Original start category: " ++ origStart]
+    xmlGr = grammar root l ([meta "description" 
+                             ("SRGS XML speech recognition grammar for " ++ name
+                              ++ ". " ++ "Original start category: " ++ origStart),
+                             meta "generator" "GF"]
 			  ++ map ruleToXML rs)
     ruleToXML (SRGRule cat origCat alts) = 
 	rule (prCat cat) (comments ["Category " ++ origCat] ++ [prRhs alts])
     prRhs rhss = oneOf (map prAlt rhss)
-    prAlt (SRGAlt p rhs) = item p (map prSymbol rhs)
-    prSymbol (Cat c) = Tag "ruleref" [("uri","#" ++ prCat c)] []
-    prSymbol (Tok t) = item Nothing [Data (showToken t)]
-    prCat c = c -- FIXME: escape something?
-    showToken t = t -- FIXME: escape something?
+    prAlt (SRGAlt p n@(Name _ pr) rhs) 
+          | sisr = prodItem (Just n) p (map (uncurry (symItem pr)) (numberCats 0 rhs))
+          | otherwise = prodItem Nothing p (map (\s -> symItem [] s 0) rhs)
+    numberCats _ [] = []
+    numberCats n (s@(Cat _):ss) = (s,n):numberCats (n+1) ss
+    numberCats n (s:ss) = (s,n):numberCats n ss
 
-rule :: String -- ^ id
-     -> [XML] -> XML
+rule :: String -> [XML] -> XML
 rule i = Tag "rule" [("id",i)]
 
-item :: Maybe Double -> [XML] -> XML
--- FIXME: what is the weight called?
-item mp xs = Tag "item" as cs
-  where as = maybe [] (\p -> [("weight", show p)]) mp
-	cs = case xs of
-		     [Tag "item" [] xs'] -> xs'
-		     _ -> xs
+prodItem :: Maybe Name -> Maybe Double -> [XML] -> XML
+prodItem n mp xs = Tag "item" w (t++cs)
+  where 
+  w = maybe [] (\p -> [("weight", show p)]) mp
+  t = maybe [] prodTag n
+  cs = case xs of
+	       [Tag "item" [] xs'] -> xs'
+	       _ -> xs
+
+prodTag :: Name -> [XML]
+prodTag (Name f prs) = [Tag "tag" [] [Data (join "; " ts)]]
+  where 
+  ts = ["$.name=" ++ showFun f] ++
+       ["$.arg" ++ show n ++ "=" ++ argInit (prs!!n) 
+            | n <- [0..length prs-1]]
+  argInit (Unify _) = metavar
+  argInit (Constant f) = maybe metavar showFun (forestName f)
+  showFun = show . prIdent
+  metavar = show "?"
+
+symItem :: [Profile a] -> Symbol String Token -> Int -> XML
+symItem prs (Cat c) x = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t)
+  where 
+  t = if null ts then [] else [Tag "tag" [] [Data (join "; " ts)]]
+  ts = ["$.arg" ++ show n ++ "=$$" 
+            | n <- [0..length prs-1], inProfile x (prs!!n)]
+symItem _ (Tok t) _ = Tag "item" [] [Data (showToken t)]
+
+inProfile :: Int -> Profile a -> Bool
+inProfile x (Unify xs) = x `elem` xs
+inProfile _ (Constant _) = False
+
+prCat :: String -> String
+prCat c = c -- FIXME: escape something?
+
+showToken :: Token -> String
+showToken t = t -- FIXME: escape something?
 
 oneOf :: [XML] -> XML
 oneOf [x] = x
@@ -88,6 +119,9 @@ grammar root l = Tag "grammar" [("xml:lang", l),
 			        ("mode","voice"),
 			        ("root",root)]
 
+meta :: String -> String -> XML
+meta n c = Tag "meta" [("name",n),("content",c)] []
+
 comments :: [String] -> [XML]
 comments = map Comment