blob: c7cb283c66df63bdb2927362f6f61a6a2702126f (
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
{-
**************************************************************
GF Module
Description : This module prints a CFG as a Nuance GSL 2.0
grammar.
Author : Björn Bringert (bringert@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : September 13, 2004
Modified :
**************************************************************
-}
-- FIXME: this modules should not be in cfgm, but where?
-- FIXME: remove left-recursion
-- FIXME: remove empty rules
-- FIXME: remove categories with no RHS
-- FIXME: remove / warn / fail if there are int / string literal
-- categories in the grammar
-- FIXME: figure out name prefix from grammar name
module PrGSL (gslPrinter) where
import Ident
import CFGrammar
import Parser (Symbol(..))
import GrammarTypes
import PrintParser
import TransformCFG
import Option
import Data.List
import Data.Maybe (fromMaybe)
import Data.FiniteMap
data GSLGrammar = GSLGrammar String -- ^ grammar name
String -- ^ start category name
[GSLRule]
data GSLRule = GSLRule String [GSLAlt]
type GSLAlt = [Symbol String Token]
type CatNames = FiniteMap String String
gslPrinter :: Ident -- ^ Grammar name
-> Options -> CFGrammar -> String
gslPrinter name opts = prGSL (prIdent name) start
where mstart = getOptVal opts gStartCat
start = fromMaybe "S" mstart ++ "{}.s"
prGSL :: String -- ^ Grammar name
-> String -- ^ startcat
-> CFGrammar -> String
prGSL name start cfg = prGSLGrammar names gsl ""
where
cfg' = makeNice cfg
gsl = cfgToGSL name start cfg'
names = mkCatNames gsl
cfgToGSL :: String -- ^ grammar name
-> String -- ^ start category
-> [CFRule_] -> GSLGrammar
cfgToGSL name start =
GSLGrammar name start . map cfgRulesToGSLRule . sortAndGroupBy ruleCat
where
ruleCat (Rule c _ _) = c
ruleRhs (Rule _ r _) = r
cfgRulesToGSLRule rs@(r:_) = GSLRule (ruleCat r) (map ruleRhs rs)
mkCatNames :: GSLGrammar -> CatNames
mkCatNames (GSLGrammar name start rules) = listToFM (zip lhsCats names)
where names = [name ++ "_" ++ show x | x <- [0..]]
lhsCats = [ c | GSLRule c _ <- rules]
prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
prGSLGrammar names (GSLGrammar name start g) =
header . mainCat . unlinesS (map prGSLrule g)
where
header = showString ";GSL2.0" . nl
. comments ["Nuance speech recognition grammar for " ++ name,
"Generated by GF"] . nl . nl
mainCat = showString ("; Start category: " ++ start) . nl
. showString ".MAIN " . prGSLCat start . nl . nl
prGSLrule (GSLRule cat rhs) =
showString "; " . prtS cat . nl
. prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
prGSLAlt rhs = wrap "(" (unwordsS (map prGSLSymbol rhs')) ")"
where rhs' = rmPunct rhs
prGSLSymbol (Cat c) = prGSLCat c
prGSLSymbol (Tok t) = wrap "\"" (prtS t) "\""
prGSLCat c = showString n
where n = case lookupFM names c of
Nothing -> error $ "Unknown category: " ++ c
Just x -> x
rmPunct :: [Symbol String Token] -> [Symbol String Token]
rmPunct [] = []
rmPunct (Tok t:ss) | all isPunct (prt t) = rmPunct ss
rmPunct (s:ss) = s : rmPunct ss
isPunct :: Char -> Bool
isPunct c = c `elem` "-_.;.,?!"
comments :: [String] -> ShowS
comments = unlinesS . map (showString . ("; " ++))
--
-- * Utils
--
nl :: ShowS
nl = showChar '\n'
sp :: ShowS
sp = showChar ' '
wrap :: String -> ShowS -> String -> ShowS
wrap o s c = showString o . s . showString c
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
unwordsS :: [ShowS] -> ShowS
unwordsS = concatS . intersperse sp
unlinesS :: [ShowS] -> ShowS
unlinesS = concatS . intersperse nl
sortAndGroupBy :: Ord b =>
(a -> b) -- ^ Gets the value to sort and group by
-> [a]
-> [[a]]
sortAndGroupBy f = groupBy (both (==) f) . sortBy (both compare f)
both :: (b -> b -> c) -> (a -> b) -> a -> a -> c
both f g x y = f (g x) (g y)
prtS :: Print a => a -> ShowS
prtS = showString . prt
|
