module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where
import GF.Data.XML
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import PGF (PGF, CId, Token)
import Data.List
import Data.Maybe
srgsXmlPrinter :: Options
-> PGF -> CId -> String
srgsXmlPrinter :: Options -> PGF -> CId -> String
srgsXmlPrinter Options
opts PGF
pgf CId
cnc = Maybe SISRFormat -> SRG -> String
prSrgsXml Maybe SISRFormat
sisr (SRG -> String) -> SRG -> String
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG Options
opts PGF
pgf CId
cnc
where sisr :: Maybe SISRFormat
sisr = (Flags -> Maybe SISRFormat) -> Options -> Maybe SISRFormat
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe SISRFormat
optSISR Options
opts
srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsXmlNonRecursivePrinter Options
opts PGF
pgf CId
cnc = Maybe SISRFormat -> SRG -> String
prSrgsXml Maybe SISRFormat
forall a. Maybe a
Nothing (SRG -> String) -> SRG -> String
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeNonRecursiveSRG Options
opts PGF
pgf CId
cnc
prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml Maybe SISRFormat
sisr SRG
srg = XML -> String
showXMLDoc (XML -> XML
optimizeSRGS XML
xmlGr)
where
xmlGr :: XML
xmlGr = Maybe SISRFormat -> String -> Maybe String -> [XML] -> XML
grammar Maybe SISRFormat
sisr (SRG -> String
srgStartCat SRG
srg) (SRG -> Maybe String
srgLanguage SRG
srg) ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$
[String -> String -> XML
meta String
"description"
(String
"SRGS XML speech recognition grammar for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SRG -> String
srgName SRG
srg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."),
String -> String -> XML
meta String
"generator" String
"Grammatical Framework"]
[XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ (SRGRule -> XML) -> [SRGRule] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map SRGRule -> XML
ruleToXML (SRG -> [SRGRule]
srgRules SRG
srg)
ruleToXML :: SRGRule -> XML
ruleToXML (SRGRule String
cat [SRGAlt]
alts) = String -> [Attr] -> [XML] -> XML
Tag String
"rule" ([(String
"id",String
cat)][Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++[Attr]
pub) ([SRGAlt] -> [XML]
prRhs [SRGAlt]
alts)
where pub :: [Attr]
pub = if SRG -> String -> Bool
isExternalCat SRG
srg String
cat then [(String
"scope",String
"public")] else []
prRhs :: [SRGAlt] -> [XML]
prRhs [SRGAlt]
rhss = [[XML] -> XML
oneOf ((SRGAlt -> XML) -> [SRGAlt] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe SISRFormat -> SRGAlt -> XML
mkProd Maybe SISRFormat
sisr) [SRGAlt]
rhss)]
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd Maybe SISRFormat
sisr (SRGAlt Maybe Double
mp CFTerm
n SRGItem
rhs) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [] ([XML]
ti [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [XML
x] [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [XML]
tf)
where x :: XML
x = Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem Maybe SISRFormat
sisr CFTerm
n SRGItem
rhs
ti :: [XML]
ti = Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Maybe SISRFormat
sisr (CFTerm -> SISRFormat -> SISRTag
profileInitSISR CFTerm
n)
tf :: [XML]
tf = Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Maybe SISRFormat
sisr (CFTerm -> SISRFormat -> SISRTag
profileFinalSISR CFTerm
n)
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem Maybe SISRFormat
sisr CFTerm
cn = SRGItem -> XML
f
where
f :: SRGItem -> XML
f (REUnion []) = String -> [Attr] -> XML
ETag String
"ruleref" [(String
"special",String
"VOID")]
f (REUnion [SRGItem]
xs)
| Bool -> Bool
not ([SRGItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SRGItem]
es) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [(String
"repeat",String
"0-1")] [SRGItem -> XML
f ([SRGItem] -> SRGItem
forall a. [RE a] -> RE a
REUnion [SRGItem]
nes)]
| Bool
otherwise = [XML] -> XML
oneOf ((SRGItem -> XML) -> [SRGItem] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map SRGItem -> XML
f [SRGItem]
xs)
where ([SRGItem]
es,[SRGItem]
nes) = (SRGItem -> Bool) -> [SRGItem] -> ([SRGItem], [SRGItem])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition SRGItem -> Bool
forall a. RE a -> Bool
isEpsilon [SRGItem]
xs
f (REConcat []) = String -> [Attr] -> XML
ETag String
"ruleref" [(String
"special",String
"NULL")]
f (REConcat [SRGItem]
xs) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [] ((SRGItem -> XML) -> [SRGItem] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map SRGItem -> XML
f [SRGItem]
xs)
f (RERepeat SRGItem
x) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [(String
"repeat",String
"0-")] [SRGItem -> XML
f SRGItem
x]
f (RESymbol Symbol SRGNT String
s) = Maybe SISRFormat -> CFTerm -> Symbol SRGNT String -> XML
symItem Maybe SISRFormat
sisr CFTerm
cn Symbol SRGNT String
s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT String -> XML
symItem Maybe SISRFormat
sisr CFTerm
cn (NonTerminal n :: SRGNT
n@(String
c,Int
_)) =
String -> [Attr] -> [XML] -> XML
Tag String
"item" [] ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ [String -> [Attr] -> XML
ETag String
"ruleref" [(String
"uri",String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c)]] [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Maybe SISRFormat
sisr (CFTerm -> SRGNT -> SISRFormat -> SISRTag
catSISR CFTerm
cn SRGNT
n)
symItem Maybe SISRFormat
_ CFTerm
_ (Terminal String
t) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [] [String -> XML
Data (String -> String
showToken String
t)]
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Maybe SISRFormat
Nothing SISRFormat -> SISRTag
_ = []
tag (Just SISRFormat
fmt) SISRFormat -> SISRTag
t = case SISRFormat -> SISRTag
t SISRFormat
fmt of
[] -> []
SISRTag
ts -> [String -> [Attr] -> [XML] -> XML
Tag String
"tag" [] [String -> XML
Data (SISRTag -> String
prSISR SISRTag
ts)]]
showToken :: Token -> String
showToken :: String -> String
showToken String
t = String
t
oneOf :: [XML] -> XML
oneOf :: [XML] -> XML
oneOf = String -> [Attr] -> [XML] -> XML
Tag String
"one-of" []
grammar :: Maybe SISRFormat
-> String
-> Maybe String
-> [XML] -> XML
grammar :: Maybe SISRFormat -> String -> Maybe String -> [XML] -> XML
grammar Maybe SISRFormat
sisr String
root Maybe String
ml =
String -> [Attr] -> [XML] -> XML
Tag String
"grammar" ([Attr] -> [XML] -> XML) -> [Attr] -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ [(String
"xmlns",String
"http://www.w3.org/2001/06/grammar"),
(String
"version",String
"1.0"),
(String
"mode",String
"voice"),
(String
"root",String
root)]
[Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ (if Maybe SISRFormat -> Bool
forall a. Maybe a -> Bool
isJust Maybe SISRFormat
sisr then [(String
"tag-format",String
"semantics/1.0")] else [])
[Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ [Attr] -> (String -> [Attr]) -> Maybe String -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
l -> [(String
"xml:lang", String
l)]) Maybe String
ml
meta :: String -> String -> XML
meta :: String -> String -> XML
meta String
n String
c = String -> [Attr] -> XML
ETag String
"meta" [(String
"name",String
n),(String
"content",String
c)]
optimizeSRGS :: XML -> XML
optimizeSRGS :: XML -> XML
optimizeSRGS = (XML -> XML) -> XML -> XML
bottomUpXML XML -> XML
f
where f :: XML -> XML
f (Tag String
"item" [] [x :: XML
x@(Tag String
"item" [Attr]
_ [XML]
_)]) = XML
x
f (Tag String
"item" [] [x :: XML
x@(Tag String
"one-of" [Attr]
_ [XML]
_)]) = XML
x
f (Tag String
"item" [Attr]
as [Tag String
"item" [] [XML]
xs]) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [Attr]
as [XML]
xs
f (Tag String
"item" [Attr]
as [XML]
xs) = String -> [Attr] -> [XML] -> XML
Tag String
"item" [Attr]
as ((XML -> XML) -> [XML] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map XML -> XML
g [XML]
xs)
where g :: XML -> XML
g (Tag String
"item" [] [x :: XML
x@(ETag String
"ruleref" [Attr]
_)]) = XML
x
g XML
x = XML
x
f (Tag String
"one-of" [] [XML
x]) = XML
x
f XML
x = XML
x