forked from GitHub/gf-core
110 lines
3.4 KiB
Haskell
110 lines
3.4 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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,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]
|
|
++ 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
|
|
|
|
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)]
|
|
|
|
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 |