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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% %
% Frown --- An LALR(k) parser generator for Haskell 98 %
% Copyright (C) 2001-2005 Ralf Hinze %
% %
% This program is free software; you can redistribute it and/or modify %
% it under the terms of the GNU General Public License (version 2) as %
% published by the Free Software Foundation. %
% %
% This program is distributed in the hope that it will be useful, %
% but WITHOUT ANY WARRANTY; without even the implied warranty of %
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the %
% GNU General Public License for more details. %
% %
% You should have received a copy of the GNU General Public License %
% along with this program; see the file COPYING. If not, write to %
% the Free Software Foundation, Inc., 59 Temple Place - Suite 330, %
% Boston, MA 02111-1307, USA. %
% %
% Contact information %
% Email: Ralf Hinze <ralf@cs.uni-bonn.de> %
% Homepage: http://www.informatik.uni-bonn.de/~ralf/ %
% Paper mail: Dr. Ralf Hinze %
% Institut für Informatik III %
% Universität Bonn %
% Römerstraße 164 %
% 53117 Bonn, Germany %
% %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
> module LR0 ( Item(..), Items(..), toList
> , lr0automaton, State(..), Edge, GotoTable
> , Future(..), fromList, union, unionMany, prune
> , lr0info, Action(..), Table, isErrCorr )
> where
> import Grammar
> import qualified OrdUniqListSet as Set
> import OrdUniqListSet ( Set, set, list, fixedpoint )
> import qualified OrdUniqListFM as FM
> import OrdUniqListFM ( FM )
> import qualified SearchTree as BST
> import Prettier hiding ( concat, empty )
> import Haskell
> import Future hiding ( lookup )
> import Base hiding ( list )
> import qualified Base
> import Prelude hiding ( null )
> import System.IO
> import Options
%-------------------------------= --------------------------------------------
\section{LR(0) items}
%-------------------------------= --------------------------------------------
An item is a rule with a dot on the right-hand side. We represent the
dotted rhs using a reversed list (a stack) and an ordinary list.
> data Item = Item { inumber :: Int
> , ilhs :: Symbol
> , istack :: RevList Symbol
> , iinput :: List Symbol
> , iprec :: Prec }
> deriving (Eq, Ord, Show)
>
> instance Pretty Item where
> prettyPrec d (Item i n l r p)
> = prettyPrec d (Rule i n (shunt l (dot : r)) p)
> where dot = Terminal{ pattern = con ".", modifier = Copy } -- HACK
>
> item :: Rule -> Item
> item (Rule i n r p) = Item i n Nil r p
Items are either kernel items or predict items. We represent item sets
as the disjoint union of kernel items and predict items. Note that
empty productions are classified as predict items.
> data Items = Set Item :\/ Set Item
> deriving (Show)
>
> instance Pretty Items where
> prettyPrec d (q :\/ _) = prettyPrec d q
> instance Eq Items where
> (q1 :\/ _) == (q2 :\/ _) = q1 == q2
>
> instance Ord Items where
> compare (q1 :\/ _) (q2 :\/ _)
> = compare q1 q2
Since the kernel items determine the predict items we only compare the
kernel items.
> toList :: Items -> [Item]
> toList (q :\/ q') = list (q `Set.union` q')
>
> null :: Items -> Bool
> null (q :\/ _) = Set.null q
%-------------------------------= --------------------------------------------
\section{LR(0) automaton}
%-------------------------------= --------------------------------------------
A state is a numbered item set. The number uniquely determines the
item set.
> data State = State { snumber :: Int
> , items :: Items }
> deriving (Show)
>
> instance Eq State where
> s1 == s2 = snumber s1 == snumber s2
>
> instance Ord State where
> compare s1 s2 = compare (snumber s1) (snumber s2)
>
> instance Pretty State where
> pretty s = pretty (snumber s)
Calculation of the LR(0) automaton.
> type Edge = (State, Symbol, State)
>
> type GotoTable = [Edge]
> lr0automaton :: [Flag] -> Grammar -> IO ( [State]
> , [(Symbol, State)]
> , GotoTable
> , Set Symbol)
> lr0automaton opts g = do verb "* Computing LR(0) automaton ..."
> verb (" " ++ show (length states) ++ " states")
> verb (" " ++ show (length gotoTable) ++ " transitions")
TODO: pretty print not reachable nts.
> verb (" " ++ show (Set.length reachable) ++ " reachable nonterminals (not reachable: " ++
> show (Set.minus (set (nonterminals g)) reachable) ++ ")")
> return (states, initials, gotoTable, reachable)
> where
> verb = verbose opts
>
> closure :: Set Item -> Items
> closure q = q :\/ predict q
>
> predict :: Set Item -> Set Item
> predict q0 = fixedpoint step (step q0)
> where step q = set [ item p
> | Item _ _ _ (v : _) _ <- list q
> , nonterminal v
> , p <- productionsOf g v ]
>
> goto :: Items -> FM Symbol Items
> goto q = fmap closure $
> FM.fromList_C Set.union
> [ (v, Set.singleton (Item i n (l :> v) r a))
> | Item i n l (v : r) a <- toList q ]
Each start symbol gives rise to an initial item set.
> starts = [ (t, q0 t) | t <- startSymbols g ] --nonterminals g, isStart t ]
> where q0 s = closure $ set [ item r | r <- productions g, rlhs r == s]
>
> itemSets = fixedpoint step (set (map snd starts))
> where step qs = set [ q'
> | q <- list qs
> , (_, q') <- FM.toList (goto q) ]
For reasons of effiency and convenience we number the states.
> fm = [ (q, State n q)
> | (q, n) <- zip (list itemSets) [1 ..] ]
>
> states = map snd fm
>
> initials = [ (t, safeLookup q) | (t, q) <- starts ]
>
> gotoTable = [ (n, v, safeLookup q')
> | (q, n) <- fm
> , (v, q') <- FM.toList (goto q)
> , not (null q') ] -- we don't list error transitions
> safeLookup a = case lookup a fm of
> Nothing -> error (render (Page 80) (pretty a <> nl <> pretty fm <> nl <> pretty starts))
> Just v -> v
Determine reachable nonterminals. NB We should use a binary search
tree instead of an ordered list here:
> reachable = set [ v | s <- states, Item _ v _ [] _ <- toList (items s) ]
%-------------------------------= --------------------------------------------
\section{Shift and reduce table}
%-------------------------------= --------------------------------------------
> type Table = [Action]
>
> data Action = Shift { goto :: Edge }
> | Reduce { stack :: RevList Edge
> , goto :: Edge
> , future :: Future
> , prec :: Prec
> , pnumber :: Int }
> deriving (Show)
>
> instance Eq Action where
> Shift e == Shift e' = e == e'
> Reduce st e _f _a i == Reduce st' e' _f' _a' i'
> = (i, st, e) == (i', st', e')
> _ == _ = False
>
> instance Ord Action where
> compare (Shift e) (Shift e')
> = compare e e'
> compare (Shift {}) (Reduce {})
> = LT
> compare (Reduce {}) (Shift {})
> = GT
> compare (Reduce st e _f _a i) (Reduce st' e' _f' _a' i')
> = compare (i, st, e) (i', st', e')
Note that the reduce actions are (first) ordered by the (length of
the) right-hand side (in particular, the productions must not be
ordered by |pnumber|).
> instance Pretty Action where
> prettyPrec d (Shift e) = condParens (d > 9)
> $ block 4 (string "shift " </> pretty e)
> prettyPrec d (Reduce st e f a i)
> = condParens (d > 9)
> $ block 4 (string ("reduce by " ++ show i ++ ":")
> </> intersperse nl (map pretty (Base.list st))
> </> string "=>" <+> pretty e
> </> prettyPrec 10 f
> </> prettyPrec 10 a)
> isErrCorr :: Action -> Bool
> isErrCorr (Shift (_, v, _)) = terminal v && modifier v `elem` [Insert, Delete]
> isErrCorr (Reduce {}) = False
> lr0info :: [Flag] -> [State] -> GotoTable -> IO Table
> lr0info opts states gotoTable = do verb "* Computing actions ..."
> verb (" " ++ show (length shiftTable) ++ " shift actions")
> verb (" " ++ show (length reduceTable) ++ " reduce actions")
> return (shiftTable ++ reduceTable)
> where
> verb = verbose opts
>
> shiftTable = [ Shift e
> | e@(_, t, _) <- gotoTable
> , terminal t ]
>
> reduceTable = [ Reduce st (s', v, goto s' v) (fromList []) p i
> | n <- states
> , Item i v l [] p <- toList (items n)
> , (st, s') <- backtrack l n ]
>
> backtrack Nil s = [ (Nil, s) ]
> backtrack (vs :> v) s = [ (st :> (s', v, s), x)
> | s' <- list (invGoto v s)
> , (st, x) <- backtrack vs s' ]
>
> goto s v = applyWithDefault (BST.lookup fm) errorState (s, v)
> where fm = BST.fromList [ ((si, vi), si') | (si, vi, si') <- gotoTable ]
>
> invGoto v s' = applyWithDefault (BST.lookup fm) Set.empty (v, s')
> where fm = BST.fromList_C Set.union
> [ ((vi, si'), Set.singleton si) | (si, vi, si') <- gotoTable ]
State |0| is the error or trap state and the goto state for start
productions such as |Start# : Start, EOF;|.
> errorState :: State
> errorState = State 0 (Set.empty :\/ Set.empty)
|
