blob: ceaf86ae04b2275f27c9ef63b947744bec515d56 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
----------------------------------------------------------------------
-- |
-- 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 = 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
|
