----------------------------------------------------------------------
-- |
-- Module      : GF.Speech.GSL
--
-- This module prints a CFG as a Nuance GSL 2.0 grammar.
--
-----------------------------------------------------------------------------

module GF.Speech.GSL (gslPrinter) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

--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 :: Int
width = Int
75

gslPrinter :: Options -> PGF -> CId -> String
gslPrinter :: Options -> PGF -> CId -> String
gslPrinter Options
opts PGF
pgf CId
cnc = Style -> Doc -> String
forall a. Pretty a => Style -> a -> String
renderStyle Style
st (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ SRG -> Doc
prGSL (SRG -> Doc) -> SRG -> Doc
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG Options
opts PGF
pgf CId
cnc
  where st :: Style
st = Style
style { lineLength :: Int
lineLength = Int
width }

prGSL :: SRG -> Doc
prGSL :: SRG -> Doc
prGSL SRG
srg = Doc
header Doc -> Doc -> Doc
$++$ Doc
mainCat Doc -> Doc -> Doc
$++$ (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($++$) Doc
empty ((SRGRule -> Doc) -> [SRGRule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGRule -> Doc
prRule (SRG -> [SRGRule]
srgRules SRG
srg))
    where
    header :: Doc
header = String
";GSL2.0" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
             String -> Doc
comment (String
"Nuance speech recognition grammar for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SRG -> String
srgName SRG
srg) Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
             String -> Doc
comment (String
"Generated by GF")
    mainCat :: Doc
mainCat = String
".MAIN" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String -> Doc
prCat (SRG -> String
srgStartCat SRG
srg)
    prRule :: SRGRule -> Doc
prRule (SRGRule String
cat [SRGAlt]
rhs) = String -> Doc
prCat String
cat Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> [Doc] -> Doc
union ((SRGAlt -> Doc) -> [SRGAlt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGAlt -> Doc
prAlt [SRGAlt]
rhs)
    -- FIXME: use the probability
    prAlt :: SRGAlt -> Doc
prAlt (SRGAlt Maybe Double
mp CFTerm
_ SRGItem
rhs) = SRGItem -> Doc
prItem SRGItem
rhs


prItem :: SRGItem -> Doc
prItem :: SRGItem -> Doc
prItem = SRGItem -> Doc
f
  where
    f :: SRGItem -> Doc
f (REUnion [SRGItem]
xs) = (if [SRGItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SRGItem]
es then Doc
empty else String -> Doc
forall a. Pretty a => a -> Doc
pp String
"?") Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> [Doc] -> Doc
union ((SRGItem -> Doc) -> [SRGItem] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGItem -> Doc
f [SRGItem]
nes)
      where ([SRGItem]
es,[SRGItem]
nes) = (SRGItem -> Bool) -> [SRGItem] -> ([SRGItem], [SRGItem])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition SRGItem -> Bool
forall a. RE a -> Bool
isEpsilon [SRGItem]
xs
    f (REConcat [SRGItem
x]) = SRGItem -> Doc
f SRGItem
x
    f (REConcat [SRGItem]
xs) = String
"(" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((SRGItem -> Doc) -> [SRGItem] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGItem -> Doc
f [SRGItem]
xs) Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> String
")"
    f (RERepeat SRGItem
x)  = String
"*" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> SRGItem -> Doc
f SRGItem
x
    f (RESymbol Symbol SRGNT String
s)  = Symbol SRGNT String -> Doc
prSymbol Symbol SRGNT String
s

union :: [Doc] -> Doc
union :: [Doc] -> Doc
union [Doc
x] = Doc
x
union [Doc]
xs = String
"[" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep [Doc]
xs Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> String
"]"

prSymbol :: Symbol SRGNT Token -> Doc
prSymbol :: Symbol SRGNT String -> Doc
prSymbol = (SRGNT -> Doc) -> (String -> Doc) -> Symbol SRGNT String -> Doc
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (String -> Doc
prCat (String -> Doc) -> (SRGNT -> String) -> SRGNT -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRGNT -> String
forall a b. (a, b) -> a
fst) (Doc -> Doc
forall a. Pretty a => a -> Doc
doubleQuotes (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
showToken)

-- GSL requires an upper case letter in category names
prCat :: Cat -> Doc
prCat :: String -> Doc
prCat = String -> Doc
forall a. Pretty a => a -> Doc
pp (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
firstToUpper


firstToUpper :: String -> String
firstToUpper :: String -> String
firstToUpper [] = []
firstToUpper (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
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 :: String -> Doc
showToken = String -> Doc
forall a. Pretty a => a -> Doc
pp (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

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

comment :: String -> Doc
comment :: String -> Doc
comment String
s = String
";" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
s


-- Pretty-printing utilities

emptyLine :: Doc
emptyLine :: Doc
emptyLine = String -> Doc
forall a. Pretty a => a -> Doc
pp String
""

($++$) :: Doc -> Doc -> Doc
Doc
x $++$ :: Doc -> Doc -> Doc
$++$ Doc
y = Doc
x Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
emptyLine Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
y