----------------------------------------------------------------------
-- |
-- 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