1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
----------------------------------------------------------------------
-- |
-- Module : PrSRGS
-- Maintainer : BB
-- 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
import GF.Data.Utilities
import GF.Speech.SRG
import GF.Infra.Ident
import GF.Formalism.CFG
import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName)
import GF.Conversion.Types
import GF.Infra.Print
import GF.Infra.Option
import GF.Probabilistic.Probabilistic (Probs)
import Data.Char (toUpper,toLower)
data XML = Data String | Tag String [Attr] [XML] | Comment String
deriving (Eq,Show)
type Attr = (String,String)
srgsXmlPrinter :: Ident -- ^ Grammar name
-> Options
-> Bool -- ^ Whether to include semantic interpretation
-> Maybe Probs
-> CGrammar -> String
srgsXmlPrinter name opts sisr probs cfg = prSrgsXml sisr srg ""
where srg = makeSRG name opts probs cfg
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 ([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 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 -> [XML] -> XML
rule i = Tag "rule" [("id",i)]
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
oneOf xs = Tag "one-of" [] xs
grammar :: String -- ^ root
-> String -- ^languageq
-> [XML] -> XML
grammar root l = Tag "grammar" [("xml:lang", l),
("xmlns","http://www.w3.org/2001/06/grammar"),
("version","1.0"),
("mode","voice"),
("root",root)]
meta :: String -> String -> XML
meta n c = Tag "meta" [("name",n),("content",c)] []
comments :: [String] -> [XML]
comments = map Comment
showsXML :: XML -> ShowS
showsXML (Data s) = showString s
showsXML (Tag t as []) = showChar '<' . showString t . showsAttrs as . showString "/>"
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 " -->"
showsAttrs :: [Attr] -> ShowS
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
showsAttr :: Attr -> ShowS
showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
-- FIXME: escape strange charachters with &#xxx;
escape :: String -> String
escape = concatMap escChar
where
escChar c | c `elem` ['"','\\'] = '\\':[c]
| otherwise = [c]
|
