module GF.Speech.GSL (gslPrinter) where
import Prelude hiding ((<>))
import GF.Grammar.CFG
import GF.Speech.SRG
import GF.Speech.RegExp
import GF.Infra.Option
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)
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)
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
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
comment :: String -> Doc
String
s = String
";" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
s
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