----------------------------------------------------------------------
-- |
-- Module      : GF.Speech.SRGS_XML
--
-- Prints an SRGS XML speech recognition grammars.
----------------------------------------------------------------------
module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where

--import GF.Data.Utilities
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 Control.Monad
--import Data.Char (toUpper,toLower)
import Data.List
import Data.Maybe
--import qualified Data.Map as Map

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  -- ^ root
        -> Maybe String -- ^language
        -> [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