GF.Speech.GSL

module GF.Speech.GSL (gslPrinter) where

--import GF.Data.Utilities
import GF.Grammar.CFG
import GF.Speech.SRG
import GF.Speech.RegExp
import GF.Infra.Option
--import GF.Infra.Ident
import PGF

import Data.Char (toUpper,toLower)
import Data.List (partition)
import GF.Text.Pretty

width :: Int
width = 75

gslPrinter :: Options -> PGF -> CId -> String
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
  where st = style { lineLength = width } 

prGSL :: SRG -> Doc
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
    where
    header = ";GSL2.0" $$
	     comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
             comment ("Generated by GF") 
    mainCat = ".MAIN" <+> prCat (srgStartCat srg)
    prRule (SRGRule cat rhs) = 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 pp "?") <> union (map f nes)
      where (es,nes) = partition isEpsilon xs
    f (REConcat [x]) = f x
    f (REConcat xs) = "(" <> fsep (map f xs) <> ")"
    f (RERepeat x)  = "*" <> f x
    f (RESymbol s)  = prSymbol s

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

prSymbol :: Symbol SRGNT Token -> Doc
prSymbol = symbol (prCat . fst) (doubleQuotes . showToken)

-- GSL requires an upper case letter in category names
prCat :: Cat -> Doc
prCat = pp . firstToUpper


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 = pp . map toLower

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

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


-- Pretty-printing utilities

emptyLine :: Doc
emptyLine = pp ""

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