----------------------------------------------------------------------
-- |
-- 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.Speech.RegExp
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)
import Data.List (partition)
import Text.PrettyPrint.HughesPJ

width :: Int
width = 75

gslPrinter :: Options -> StateGrammar -> String
gslPrinter opts s = renderStyle st $ prGSL $ makeSimpleSRG opts s
  where st = style { lineLength = width } 

prGSL :: SRG -> Doc
prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
    = header $++$ mainCat $++$ foldr ($++$) empty (map prRule rs)
    where
    header = text ";GSL2.0" $$
	     comment ("Nuance speech recognition grammar for " ++ name) $$
             comment ("Generated by GF") 
    mainCat = comment ("Start category: " ++ origStart) $$
	      text ".MAIN" <+> prCat start
    prRule (SRGRule cat origCat rhs) = 
	comment (prt origCat) $$ 
        prCat cat <+> union (map prAlt rhs)
    -- FIXME: use the probability
    prAlt (SRGAlt mp _ rhs) = prItem rhs


prItem :: SRGItem -> Doc
prItem = f
  where
    f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes)
      where (es,nes) = partition isEpsilon xs
    f (REConcat [x]) = f x
    f (REConcat xs) = text "(" <> fsep (map f xs) <> text ")"
    f (RERepeat x)  = text "*" <> f x
    f (RESymbol s)  = prSymbol s

union :: [Doc] -> Doc
union [x] = x
union xs = text "[" <> fsep xs <> text "]"

prSymbol :: Symbol SRGNT Token -> Doc
prSymbol (Cat (c,_)) = prCat c
prSymbol (Tok t) = doubleQuotes (showToken t)

-- GSL requires an upper case letter in category names
prCat :: SRGCat -> Doc
prCat c = text (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 -> Doc
showToken t = text (map toLower (prt t))

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

comment :: String -> Doc
comment s = text ";" <+> text s


-- Pretty-printing utilities

emptyLine :: Doc
emptyLine = text ""

($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y