GF.Speech.SRGS_XML

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 opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc
    where sisr = flag optSISR opts

srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc


prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
    where
    xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
              [meta "description" 
                 ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
               meta "generator" "Grammatical Framework"]
	    ++ map ruleToXML (srgRules srg)
    ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
        where pub = if isExternalCat srg cat then [("scope","public")] else []
    prRhs rhss = [oneOf (map (mkProd sisr) rhss)] 

mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
  where x = mkItem sisr n rhs
        ti = tag sisr (profileInitSISR n)
        tf = tag sisr (profileFinalSISR n)

mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f
  where 
    f (REUnion [])  = ETag "ruleref" [("special","VOID")]
    f (REUnion xs) 
        | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
        | otherwise = oneOf (map f xs)
      where (es,nes) = partition isEpsilon xs
    f (REConcat []) = ETag "ruleref" [("special","NULL")]
    f (REConcat xs) = Tag "item" [] (map f xs)
    f (RERepeat x)  = Tag "item" [("repeat","0-")] [f x]
    f (RESymbol s)  = symItem sisr cn s

symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
symItem sisr cn (NonTerminal n@(c,_)) = 
    Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]

tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Nothing _ = []
tag (Just fmt) t = case t fmt of
                     [] -> []
                     ts -> [Tag "tag" [] [Data (prSISR ts)]]

showToken :: Token -> String
showToken t = t

oneOf :: [XML] -> XML
oneOf = Tag "one-of" []

grammar :: Maybe SISRFormat
        -> String  -- ^ root
        -> Maybe String -- ^language
	-> [XML] -> XML
grammar sisr root ml = 
    Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
		     ("version","1.0"),
		     ("mode","voice"),
		     ("root",root)]
                 ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
                 ++ maybe [] (\l -> [("xml:lang", l)]) ml

meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)]

optimizeSRGS :: XML -> XML
optimizeSRGS = bottomUpXML f 
  where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
        f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
        f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs
        f (Tag "item" as xs) = Tag "item" as (map g xs)
           where g (Tag "item" [] [x@(ETag "ruleref" _)]) = x
                 g x = x
        f (Tag "one-of" [] [x]) = x
        f x = x