----------------------------------------------------------------------
-- |
-- Module      : PrGSL
-- Maintainer  : BB
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 20:09:04 $ 
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $
--
-- This module prints a CFG as a Nuance GSL 2.0 grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
-----------------------------------------------------------------------------

module GF.Speech.PrGSL (gslPrinter) 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 GF.Compile.ShellState (StateGrammar)

import Data.Char (toUpper,toLower)

gslPrinter :: Options -> StateGrammar -> String
gslPrinter opts s = prGSL $ topDownFilter $ makeSimpleSRG opts s

prGSL :: SRG -> String
prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
    = (header . mainCat . unlinesS (map prRule rs)) ""
    where
    header = showString ";GSL2.0" . nl 
	     . comments ["Nuance speech recognition grammar for " ++ name,
			 "Generated by GF"] . nl . nl
    mainCat = showString ("; Start category: " ++ origStart) . nl 
	      . showString ".MAIN " . prCat start . nl . nl
    prRule (SRGRule cat origCat rhs) = 
	showString "; " . prtS origCat . nl
        . prCat cat . sp . wrap "[" (unwordsS (map prAlt rhs)) "]" . nl
    -- FIXME: use the probability
    prAlt (SRGAlt mp _ rhs) = wrap "(" (unwordsS (map prSymbol rhs)) ")"
    prSymbol (Cat (c,_)) = prCat c
    prSymbol (Tok t) = wrap "\"" (showString (showToken t)) "\""
    -- GSL requires an upper case letter in category names
    prCat c = showString (firstToUpper c)

firstToUpper :: String -> String
firstToUpper [] = []
firstToUpper (x:xs) = toUpper x : xs

{-
rmPunctCFG :: CGrammar -> CGrammar
rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]

keepSymbol :: Symbol c Token -> Bool
keepSymbol (Tok t) = not (all isPunct (prt t))
keepSymbol _ = True
-}

-- Nuance does not like upper case characters in tokens
showToken :: Token -> String
showToken t = map toLower (prt t)

isPunct :: Char -> Bool
isPunct c = c `elem` "-_.:;.,?!()[]{}"

comments :: [String] -> ShowS
comments = unlinesS . map (showString . ("; " ++))