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
|
----------------------------------------------------------------------
-- |
-- 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(..))
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
-> Maybe Probs
-> CGrammar -> String
srgsXmlPrinter name opts probs cfg = prSrgsXml srg ""
where srg = makeSRG name opts probs cfg
prSrgsXml :: SRG -> ShowS
prSrgsXml (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= header . showsXML xmlGr
where
header = showString "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
root = prCat start
xmlGr = grammar root (comments
["SRGS XML speech recognition grammar for " ++ name,
"Generated by GF",
"Original start category: " ++ origStart]
++ 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?
rule :: String -- ^ id
-> [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
oneOf :: [XML] -> XML
oneOf [x] = x
oneOf xs = Tag "one-of" [] xs
-- FIXME: what about xml:lang?
grammar :: String -- ^ root
-> [XML] -> XML
grammar root = Tag "grammar" [("xmlns","http://www.w3.org/2001/06/grammar"),
("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance"),
("xsi:schemaLocation",
"http://www.w3.org/2001/06/grammar http://www.w3.org/TR/speech-grammar/grammar.xsd"),
("version","1.0"),
("mode","voice"),
("root",root)]
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 double quotes
escape :: String -> String
escape = id
|
