blob: dbd7d44e3544a56ef965356663604bc4ec99418a (
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
96
97
98
99
100
101
102
|
----------------------------------------------------------------------
-- |
-- 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)
gslPrinter :: Options -> StateGrammar -> String
gslPrinter opts s = prGSL $ makeSimpleSRG opts s
prGSL :: SRG -> String
prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= (header . mainCat . unlinesS (map prRule rs)) ""
where
header = showString ";GSL2.0" . nl
. comments ["Nuance speech recognition grammar for " ++ name,
"Generated by GF"] . nl . nl
mainCat = showString ("; Start category: " ++ origStart) . nl
. showString ".MAIN " . prCat start . nl . nl
prRule (SRGRule cat origCat rhs) =
showString "; " . prtS origCat . nl
. prCat cat . sp . brackets (unwordsS (map prAlt (ebnfSRGAlts rhs))) . nl
-- FIXME: use the probability
prAlt (EBnfSRGAlt mp _ rhs) = prItem rhs
prItem :: EBnfSRGItem -> ShowS
prItem = f
where
f (REUnion xs)
| not (null es) = showString "?" . f (REUnion nes)
| otherwise = brackets (unwordsS (map f xs))
where (es,nes) = partition isEpsilon xs
f (REConcat [x]) = f x
f (REConcat xs) = parens (unwordsS (map f xs))
f (RERepeat x) = showString "*" . f x
f (RESymbol s) = prSymbol s
parens x = wrap "(" x ")"
brackets x = wrap "[" x "]"
prSymbol :: Symbol SRGNT Token -> ShowS
prSymbol (Cat (c,_)) = prCat c
prSymbol (Tok t) = wrap "\"" (showString (showToken t)) "\""
-- GSL requires an upper case letter in category names
prCat :: SRGCat -> ShowS
prCat c = showString (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 -> String
showToken t = map toLower (prt t)
isPunct :: Char -> Bool
isPunct c = c `elem` "-_.:;.,?!()[]{}"
comments :: [String] -> ShowS
comments = unlinesS . map (showString . ("; " ++))
|
