← Back to branch summary

~ubuntu-branches/ubuntu/trusty/happy/trusty-proposed

« back to all changes in this revision

Viewing changes to src/ProduceCode.lhs

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2013-09-18 19:11:12 UTC
  • mfrom: (1.2.8)
  • Revision ID: package-import@ubuntu.com-20130918191112-h5he0u2g5tqnh90m
Tags: 1.19.0-1
* Fix Vcs-Darcs url: http://darcs.debian.org/ instead of
  http://darcs.debian.org/darcs/
* New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/ProduceCode.lhs
6
6
 
7
7
> module ProduceCode (produceParser) where
8
8
 
9
 
> import Paths_happy            ( version )
10
 
> import Data.Version           ( showVersion )
 
9
> import Paths_happy            ( version )
 
10
> import Data.Version           ( showVersion )
11
11
> import Grammar
12
 
> import Target                 ( Target(..) )
13
 
> import GenUtils               ( mapDollarDollar, str, char, nl, strspace,
14
 
>                                 interleave, interleave', maybestr, 
 
12
> import Target                 ( Target(..) )
 
13
> import GenUtils               ( mapDollarDollar, str, char, nl, strspace,
 
14
>                                 interleave, interleave', maybestr,
15
15
>                                 brack, brack' )
16
16
 
17
 
> import Data.Maybe                     ( isJust, isNothing )
 
17
> import Data.Maybe                     ( isJust, isNothing )
18
18
> import Data.Char
19
19
> import Data.List
20
20
 
22
22
> import Data.Array.ST      ( STUArray )
23
23
> import Data.Array.Unboxed ( UArray )
24
24
> import Data.Array.MArray
25
 
> import Data.Array.IArray 
 
25
> import Data.Array.IArray
26
26
 
27
27
%-----------------------------------------------------------------------------
28
28
Produce the complete output file.
29
29
 
30
 
> produceParser :: Grammar                      -- grammar info
31
 
>               -> ActionTable                  -- action table
32
 
>               -> GotoTable                    -- goto table
33
 
>               -> String                       -- stuff to go at the top
34
 
>               -> Maybe String                 -- module header
35
 
>               -> Maybe String                 -- module trailer
36
 
>               -> Target                       -- type of code required
37
 
>               -> Bool                         -- use coercions
38
 
>               -> Bool                         -- use ghc extensions
39
 
>               -> Bool                         -- strict parser
40
 
>               -> String
 
30
> produceParser :: Grammar                      -- grammar info
 
31
>               -> ActionTable                  -- action table
 
32
>               -> GotoTable                    -- goto table
 
33
>               -> String                       -- stuff to go at the top
 
34
>               -> Maybe String                 -- module header
 
35
>               -> Maybe String                 -- module trailer
 
36
>               -> Target                       -- type of code required
 
37
>               -> Bool                         -- use coercions
 
38
>               -> Bool                         -- use ghc extensions
 
39
>               -> Bool                         -- strict parser
 
40
>               -> String
41
41
 
42
 
> produceParser (Grammar 
43
 
>               { productions = prods
44
 
>               , non_terminals = nonterms
45
 
>               , terminals = terms
46
 
>               , types = nt_types
47
 
>               , first_nonterm = first_nonterm'
48
 
>               , eof_term = eof
49
 
>               , first_term = fst_term
50
 
>               , lexer = lexer'
51
 
>               , imported_identity = imported_identity'
52
 
>               , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return)
53
 
>               , token_specs = token_rep
54
 
>               , token_type = token_type'
55
 
>               , starts = starts'
56
 
>               , error_handler = error_handler'
 
42
> produceParser (Grammar
 
43
>               { productions = prods
 
44
>               , non_terminals = nonterms
 
45
>               , terminals = terms
 
46
>               , types = nt_types
 
47
>               , first_nonterm = first_nonterm'
 
48
>               , eof_term = eof
 
49
>               , first_term = fst_term
 
50
>               , lexer = lexer'
 
51
>               , imported_identity = imported_identity'
 
52
>               , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return)
 
53
>               , token_specs = token_rep
 
54
>               , token_type = token_type'
 
55
>               , starts = starts'
 
56
>               , error_handler = error_handler'
57
57
>               , attributetype = attributetype'
58
58
>               , attributes = attributes'
59
 
>               })
60
 
>               action goto top_options module_header module_trailer 
61
 
>               target coerce ghc strict
62
 
>     = ( top_opts
63
 
>       . maybestr module_header . nl
64
 
>       . str comment
65
 
>               -- comment goes *after* the module header, so that we
66
 
>               -- don't screw up any OPTIONS pragmas in the header.
67
 
>       . produceAbsSynDecl . nl
68
 
>       . produceTypes
69
 
>       . produceActionTable target
70
 
>       . produceReductions
71
 
>       . produceTokenConverter . nl
72
 
>       . produceIdentityStuff
73
 
>       . produceMonadStuff
74
 
>       . produceEntries
75
 
>       . produceStrict strict
 
59
>               })
 
60
>               action goto top_options module_header module_trailer
 
61
>               target coerce ghc strict
 
62
>     = ( top_opts
 
63
>       . maybestr module_header . nl
 
64
>       . str comment
 
65
>               -- comment goes *after* the module header, so that we
 
66
>               -- don't screw up any OPTIONS pragmas in the header.
 
67
>       . produceAbsSynDecl . nl
 
68
>       . produceTypes
 
69
>       . produceActionTable target
 
70
>       . produceReductions
 
71
>       . produceTokenConverter . nl
 
72
>       . produceIdentityStuff
 
73
>       . produceMonadStuff
 
74
>       . produceEntries
 
75
>       . produceStrict strict
76
76
>       . produceAttributes attributes' attributetype' . nl
77
 
>       . maybestr module_trailer . nl
78
 
>       ) ""
 
77
>       . maybestr module_trailer . nl
 
78
>       ) ""
79
79
>  where
80
80
>    n_starts = length starts'
81
81
>    token = brack token_type'
97
97
Make the abstract syntax type declaration, of the form:
98
98
 
99
99
data HappyAbsSyn a t1 .. tn
100
 
        = HappyTerminal a
101
 
        | HappyAbsSyn1 t1
102
 
        ...
103
 
        | HappyAbsSynn tn
 
100
        = HappyTerminal a
 
101
        | HappyAbsSyn1 t1
 
102
        ...
 
103
        | HappyAbsSynn tn
104
104
 
105
 
>    produceAbsSynDecl 
 
105
>    produceAbsSynDecl
106
106
 
107
107
If we're using coercions, we need to generate the injections etc.
108
108
 
109
 
        data HappyAbsSyn ti tj tk ... = HappyAbsSyn
 
109
        data HappyAbsSyn ti tj tk ... = HappyAbsSyn
110
110
 
111
111
(where ti, tj, tk are type variables for the non-terminals which don't
112
112
 have type signatures).
113
113
 
114
 
        happyIn<n> :: ti -> HappyAbsSyn ti tj tk ...
115
 
        happyIn<n> x = unsafeCoerce# x
116
 
        {-# INLINE happyIn<n> #-}
117
 
 
118
 
        happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn
119
 
        happyOut<n> x = unsafeCoerce# x
120
 
        {-# INLINE happyOut<n> #-}
121
 
 
122
 
>     | coerce 
123
 
>       = let
124
 
>             happy_item = str "HappyAbsSyn " . str_tyvars
125
 
>             bhappy_item = brack' happy_item
126
 
>
127
 
>             inject n ty
128
 
>               = mkHappyIn n . str " :: " . type_param n ty
129
 
>               . str " -> " . bhappy_item . char '\n'
130
 
>               . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
131
 
>               . str "{-# INLINE " . mkHappyIn n . str " #-}"
132
 
>
133
 
>             extract n ty
134
 
>               = mkHappyOut n . str " :: " . bhappy_item
135
 
>               . str " -> " . type_param n ty . char '\n'
136
 
>               . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
137
 
>               . str "{-# INLINE " . mkHappyOut n . str " #-}"
138
 
>         in
139
 
>           str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below
 
114
        happyIn<n> :: ti -> HappyAbsSyn ti tj tk ...
 
115
        happyIn<n> x = unsafeCoerce# x
 
116
        {-# INLINE happyIn<n> #-}
 
117
 
 
118
        happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn
 
119
        happyOut<n> x = unsafeCoerce# x
 
120
        {-# INLINE happyOut<n> #-}
 
121
 
 
122
>     | coerce
 
123
>       = let
 
124
>             happy_item = str "HappyAbsSyn " . str_tyvars
 
125
>             bhappy_item = brack' happy_item
 
126
>
 
127
>             inject n ty
 
128
>               = mkHappyIn n . str " :: " . type_param n ty
 
129
>               . str " -> " . bhappy_item . char '\n'
 
130
>               . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
 
131
>               . str "{-# INLINE " . mkHappyIn n . str " #-}"
 
132
>
 
133
>             extract n ty
 
134
>               = mkHappyOut n . str " :: " . bhappy_item
 
135
>               . str " -> " . type_param n ty . char '\n'
 
136
>               . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
 
137
>               . str "{-# INLINE " . mkHappyOut n . str " #-}"
 
138
>         in
 
139
>           str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below
140
140
>         . interleave "\n" (map str
141
141
>           [ "#if __GLASGOW_HASKELL__ >= 607",
142
142
>             "type HappyAny = Happy_GHC_Exts.Any",
143
143
>             "#else",
144
144
>             "type HappyAny = forall a . a",
145
145
>             "#endif" ])
146
 
>         . interleave "\n" 
147
 
>           [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ]
148
 
>         -- token injector
149
 
>         . str "happyInTok :: " . token . str " -> " . bhappy_item
150
 
>         . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"
151
 
>         -- token extractor
152
 
>         . str "happyOutTok :: " . bhappy_item . str " -> " . token
153
 
>         . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n"
 
146
>         . interleave "\n"
 
147
>           [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ]
 
148
>         -- token injector
 
149
>         . str "happyInTok :: " . token . str " -> " . bhappy_item
 
150
>         . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"
 
151
>         -- token extractor
 
152
>         . str "happyOutTok :: " . bhappy_item . str " -> " . token
 
153
>         . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n"
154
154
 
155
155
>         . str "\n"
156
156
 
158
158
HappyAbsSyn which is declared to be a synonym for Any.  This is the
159
159
type that GHC officially knows nothing about - it's the same type used
160
160
to implement Dynamic.  (in GHC 6.6 and older, Any didn't exist, so we
161
 
use the closest approximation namely forall a . a).  
 
161
use the closest approximation namely forall a . a).
162
162
 
163
163
It's vital that GHC doesn't know anything about this type, because it
164
164
will use any knowledge it has to optimise, and if the knowledge is
174
174
... Otherwise, output the declaration in full...
175
175
 
176
176
>     | otherwise
177
 
>       = str "data HappyAbsSyn " . str_tyvars
178
 
>       . str "\n\t= HappyTerminal " . token
179
 
>       . str "\n\t| HappyErrorToken Int\n"
180
 
>       . interleave "\n" 
 
177
>       = str "data HappyAbsSyn " . str_tyvars
 
178
>       . str "\n\t= HappyTerminal " . token
 
179
>       . str "\n\t| HappyErrorToken Int\n"
 
180
>       . interleave "\n"
181
181
>         [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty
182
 
>         | (n, ty) <- assocs nt_types, 
183
 
>           (nt_types_index ! n) == n]
 
182
>         | (n, ty) <- assocs nt_types,
 
183
>           (nt_types_index ! n) == n]
184
184
 
185
185
>     where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ]
186
 
>           str_tyvars = str (unwords all_tyvars)
 
186
>           str_tyvars = str (unwords all_tyvars)
187
187
 
188
188
%-----------------------------------------------------------------------------
189
189
Type declarations of the form:
190
190
 
191
191
type HappyReduction a b = ....
192
 
action_0, action_1 :: Int -> HappyReduction a b 
193
 
reduction_1, ...   :: HappyReduction a b 
 
192
action_0, action_1 :: Int -> HappyReduction a b
 
193
reduction_1, ...   :: HappyReduction a b
194
194
 
195
195
These are only generated if types for *all* rules are given (and not for array
196
196
based parsers -- types aren't as important there).
197
197
 
198
 
>    produceTypes 
 
198
>    produceTypes
199
199
>     | target == TargetArrayBased = id
200
200
 
201
201
>     | all isJust (elems nt_types) =
202
202
>       happyReductionDefinition . str "\n\n"
203
 
>     . interleave' ",\n " 
 
203
>     . interleave' ",\n "
204
204
>             [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ]
205
205
>                                                    (assocs action) ]
206
206
>     . str " :: " . str monad_context . str " => "
207
207
>     . intMaybeHash . str " -> " . happyReductionValue . str "\n\n"
208
 
>     . interleave' ",\n " 
209
 
>             [ mkReduceFun i | 
 
208
>     . interleave' ",\n "
 
209
>             [ mkReduceFun i |
210
210
>                     (i,_action) <- zip [ n_starts :: Int .. ]
211
211
>                                        (drop n_starts prods) ]
212
212
>     . str " :: " . str monad_context . str " => "
214
214
 
215
215
>     | otherwise = id
216
216
 
217
 
>       where intMaybeHash | ghc       = str "Happy_GHC_Exts.Int#"
218
 
>                          | otherwise = str "Int"
219
 
>             tokens = 
220
 
>               case lexer' of
221
 
>                       Nothing -> char '[' . token . str "] -> "
222
 
>                       Just _ -> id
223
 
>             happyReductionDefinition =
224
 
>                      str "{- to allow type-synonyms as our monads (likely\n"
225
 
>                    . str " - with explicitly-specified bind and return)\n"
226
 
>                    . str " - in Haskell98, it seems that with\n"
227
 
>                    . str " - /type M a = .../, then /(HappyReduction M)/\n"
228
 
>                    . str " - is not allowed.  But Happy is a\n"
229
 
>                    . str " - code-generator that can just substitute it.\n"
230
 
>                    . str "type HappyReduction m = "
231
 
>                    . happyReduction (str "m")
232
 
>                    . str "\n-}"
233
 
>             happyReductionValue =
234
 
>                      str "({-"
235
 
>                    . str "HappyReduction "
236
 
>                    . brack monad_tycon
237
 
>                    . str " = -}"
238
 
>                    . happyReduction (brack monad_tycon)
239
 
>                    . str ")"
240
 
>             happyReduction m =
241
 
>                      str "\n\t   "
242
 
>                    . intMaybeHash
243
 
>                    . str " \n\t-> " . token
244
 
>                    . str "\n\t-> HappyState "
245
 
>                    . token
246
 
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
247
 
>                    . str ")\n\t"
248
 
>                    . str "-> [HappyState "
249
 
>                    . token
250
 
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
251
 
>                    . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> "
252
 
>                    . tokens
253
 
>                    . result
254
 
>                 where result = m . str " HappyAbsSyn"
 
217
>       where intMaybeHash | ghc       = str "Happy_GHC_Exts.Int#"
 
218
>                          | otherwise = str "Int"
 
219
>             tokens =
 
220
>               case lexer' of
 
221
>                       Nothing -> char '[' . token . str "] -> "
 
222
>                       Just _ -> id
 
223
>             happyReductionDefinition =
 
224
>                      str "{- to allow type-synonyms as our monads (likely\n"
 
225
>                    . str " - with explicitly-specified bind and return)\n"
 
226
>                    . str " - in Haskell98, it seems that with\n"
 
227
>                    . str " - /type M a = .../, then /(HappyReduction M)/\n"
 
228
>                    . str " - is not allowed.  But Happy is a\n"
 
229
>                    . str " - code-generator that can just substitute it.\n"
 
230
>                    . str "type HappyReduction m = "
 
231
>                    . happyReduction (str "m")
 
232
>                    . str "\n-}"
 
233
>             happyReductionValue =
 
234
>                      str "({-"
 
235
>                    . str "HappyReduction "
 
236
>                    . brack monad_tycon
 
237
>                    . str " = -}"
 
238
>                    . happyReduction (brack monad_tycon)
 
239
>                    . str ")"
 
240
>             happyReduction m =
 
241
>                      str "\n\t   "
 
242
>                    . intMaybeHash
 
243
>                    . str " \n\t-> " . token
 
244
>                    . str "\n\t-> HappyState "
 
245
>                    . token
 
246
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
 
247
>                    . str ")\n\t"
 
248
>                    . str "-> [HappyState "
 
249
>                    . token
 
250
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
 
251
>                    . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> "
 
252
>                    . tokens
 
253
>                    . result
 
254
>                 where result = m . str " HappyAbsSyn"
255
255
 
256
256
%-----------------------------------------------------------------------------
257
257
Next, the reduction functions.   Each one has the following form:
258
258
 
259
259
happyReduce_n_m = happyReduce n m reduction where {
260
260
   reduction (
261
 
        (HappyAbsSynX  | HappyTerminal) happy_var_1 :
262
 
        ..
263
 
        (HappyAbsSynX  | HappyTerminal) happy_var_q :
264
 
        happyRest)
265
 
         = HappyAbsSynY
266
 
                ( <<user supplied string>> ) : happyRest
267
 
        ; reduction _ _ = notHappyAtAll n m
 
261
        (HappyAbsSynX  | HappyTerminal) happy_var_1 :
 
262
        ..
 
263
        (HappyAbsSynX  | HappyTerminal) happy_var_q :
 
264
        happyRest)
 
265
         = HappyAbsSynY
 
266
                ( <<user supplied string>> ) : happyRest
 
267
        ; reduction _ _ = notHappyAtAll n m
268
268
 
269
269
where n is the non-terminal number, and m is the rule number.
270
270
 
271
271
NOTES on monad productions.  These look like
272
272
 
273
 
        happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275
274
 
        happyReduction_275 (happyRest)
275
 
                =  happyThen (code) (\r -> happyReturn (HappyAbsSyn r))
 
273
        happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275
 
274
        happyReduction_275 (happyRest)
 
275
                =  happyThen (code) (\r -> happyReturn (HappyAbsSyn r))
276
276
 
277
277
why can't we pass the HappyAbsSyn constructor to happyMonadReduce and
278
278
save duplicating the happyThen/happyReturn in each monad production?
282
282
happyMonadReduce to get polymorphic recursion.  Sigh.
283
283
 
284
284
>    produceReductions =
285
 
>       interleave "\n\n" 
286
 
>          (zipWith produceReduction (drop n_starts prods) [ n_starts .. ])
 
285
>       interleave "\n\n"
 
286
>          (zipWith produceReduction (drop n_starts prods) [ n_starts .. ])
287
287
 
288
288
>    produceReduction (nt, toks, (code,vars_used), _) i
289
289
 
290
290
>     | is_monad_prod && (use_monad || imported_identity')
291
 
>       = mkReductionHdr (showInt lt) monad_reduce
292
 
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
293
 
>       . str "happyRest) tk\n\t = happyThen ("
294
 
>       . tokLets (char '(' . str code' . char ')')
295
 
>       . (if monad_pass_token then str " tk" else id)
296
 
>       . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))"
 
291
>       = mkReductionHdr (showInt lt) monad_reduce
 
292
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
 
293
>       . str "happyRest) tk\n\t = happyThen ("
 
294
>       . tokLets (char '(' . str code' . char ')')
 
295
>       . (if monad_pass_token then str " tk" else id)
 
296
>       . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))"
297
297
 
298
298
>     | specReduceFun lt
299
 
>       = mkReductionHdr id ("happySpecReduce_" ++ show lt)
300
 
>       . interleave "\n\t" tokPatterns
301
 
>       . str " =  "
302
 
>       . tokLets (
303
 
>           this_absSynCon . str "\n\t\t " 
304
 
>           . char '(' . str code' . str "\n\t)"
305
 
>         )
306
 
>       . (if coerce || null toks || null vars_used then
307
 
>                 id
308
 
>          else
309
 
>                 nl . reductionFun . strspace
310
 
>               . interleave " " (map str (take (length toks) (repeat "_")))
311
 
>               . str " = notHappyAtAll ")
 
299
>       = mkReductionHdr id ("happySpecReduce_" ++ show lt)
 
300
>       . interleave "\n\t" tokPatterns
 
301
>       . str " =  "
 
302
>       . tokLets (
 
303
>           this_absSynCon . str "\n\t\t "
 
304
>           . char '(' . str code' . str "\n\t)"
 
305
>         )
 
306
>       . (if coerce || null toks || null vars_used then
 
307
>                 id
 
308
>          else
 
309
>                 nl . reductionFun . strspace
 
310
>               . interleave " " (map str (take (length toks) (repeat "_")))
 
311
>               . str " = notHappyAtAll ")
312
312
 
313
313
>     | otherwise
314
 
>       = mkReductionHdr (showInt lt) "happyReduce"
315
 
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
316
 
>       . str "happyRest)\n\t = "
317
 
>       . tokLets
318
 
>          ( this_absSynCon . str "\n\t\t " 
319
 
>          . char '(' . str code'. str "\n\t) `HappyStk` happyRest"
320
 
>          )
321
 
 
322
 
>       where 
323
 
>               (code', is_monad_prod, monad_pass_token, monad_reduce) 
324
 
>                     = case code of 
325
 
>                         '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce")
326
 
>                         '%':'^':code1 -> (code1, True, True, "happyMonadReduce")
327
 
>                         '%':code1     -> (code1, True, False, "happyMonadReduce")
328
 
>                         _ -> (code, False, False, "")
329
 
 
330
 
>               -- adjust the nonterminal number for the array-based parser
331
 
>               -- so that nonterminals start at zero.
332
 
>               adjusted_nt | target == TargetArrayBased = nt - first_nonterm'
333
 
>                           | otherwise                  = nt
334
 
>
335
 
>               mkReductionHdr lt' s = 
336
 
>                       mkReduceFun i . str " = "
337
 
>                       . str s . strspace . lt' . strspace . showInt adjusted_nt
338
 
>                       . strspace . reductionFun . nl 
339
 
>                       . reductionFun . strspace
340
 
> 
341
 
>               reductionFun = str "happyReduction_" . shows i
342
 
>
343
 
>               tokPatterns 
344
 
>                | coerce = reverse (map mkDummyVar [1 .. length toks])
345
 
>                | otherwise = reverse (zipWith tokPattern [1..] toks)
346
 
> 
347
 
>               tokPattern n _ | n `notElem` vars_used = char '_'
348
 
>               tokPattern n t | t >= firstStartTok && t < fst_term
349
 
>                       = if coerce 
350
 
>                               then mkHappyVar n
351
 
>                               else brack' (
352
 
>                                    makeAbsSynCon t . str "  " . mkHappyVar n
353
 
>                                    )
354
 
>               tokPattern n t
355
 
>                       = if coerce
356
 
>                               then mkHappyTerminalVar n t
357
 
>                               else str "(HappyTerminal " 
358
 
>                                  . mkHappyTerminalVar n t
359
 
>                                  . char ')'
360
 
>               
361
 
>               tokLets code''
362
 
>                  | coerce && not (null cases) 
363
 
>                       = interleave "\n\t" cases
364
 
>                       . code'' . str (take (length cases) (repeat '}'))
365
 
>                  | otherwise = code''
366
 
>
367
 
>               cases = [ str "case " . extract t . strspace . mkDummyVar n
368
 
>                       . str " of { " . tokPattern n t . str " -> "
369
 
>                       | (n,t) <- zip [1..] toks,
370
 
>                         n `elem` vars_used ]
371
 
>
372
 
>               extract t | t >= firstStartTok && t < fst_term = mkHappyOut t
373
 
>                         | otherwise                     = str "happyOutTok"
374
 
>
375
 
>               lt = length toks
376
 
 
377
 
>               this_absSynCon | coerce    = mkHappyIn nt
378
 
>                              | otherwise = makeAbsSynCon nt
 
314
>       = mkReductionHdr (showInt lt) "happyReduce"
 
315
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
 
316
>       . str "happyRest)\n\t = "
 
317
>       . tokLets
 
318
>          ( this_absSynCon . str "\n\t\t "
 
319
>          . char '(' . str code'. str "\n\t) `HappyStk` happyRest"
 
320
>          )
 
321
 
 
322
>       where
 
323
>               (code', is_monad_prod, monad_pass_token, monad_reduce)
 
324
>                     = case code of
 
325
>                         '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce")
 
326
>                         '%':'^':code1 -> (code1, True, True, "happyMonadReduce")
 
327
>                         '%':code1     -> (code1, True, False, "happyMonadReduce")
 
328
>                         _ -> (code, False, False, "")
 
329
 
 
330
>               -- adjust the nonterminal number for the array-based parser
 
331
>               -- so that nonterminals start at zero.
 
332
>               adjusted_nt | target == TargetArrayBased = nt - first_nonterm'
 
333
>                           | otherwise                  = nt
 
334
>
 
335
>               mkReductionHdr lt' s =
 
336
>                       mkReduceFun i . str " = "
 
337
>                       . str s . strspace . lt' . strspace . showInt adjusted_nt
 
338
>                       . strspace . reductionFun . nl
 
339
>                       . reductionFun . strspace
 
340
>
 
341
>               reductionFun = str "happyReduction_" . shows i
 
342
>
 
343
>               tokPatterns
 
344
>                | coerce = reverse (map mkDummyVar [1 .. length toks])
 
345
>                | otherwise = reverse (zipWith tokPattern [1..] toks)
 
346
>
 
347
>               tokPattern n _ | n `notElem` vars_used = char '_'
 
348
>               tokPattern n t | t >= firstStartTok && t < fst_term
 
349
>                       = if coerce
 
350
>                               then mkHappyVar n
 
351
>                               else brack' (
 
352
>                                    makeAbsSynCon t . str "  " . mkHappyVar n
 
353
>                                    )
 
354
>               tokPattern n t
 
355
>                       = if coerce
 
356
>                               then mkHappyTerminalVar n t
 
357
>                               else str "(HappyTerminal "
 
358
>                                  . mkHappyTerminalVar n t
 
359
>                                  . char ')'
 
360
>
 
361
>               tokLets code''
 
362
>                  | coerce && not (null cases)
 
363
>                       = interleave "\n\t" cases
 
364
>                       . code'' . str (take (length cases) (repeat '}'))
 
365
>                  | otherwise = code''
 
366
>
 
367
>               cases = [ str "case " . extract t . strspace . mkDummyVar n
 
368
>                       . str " of { " . tokPattern n t . str " -> "
 
369
>                       | (n,t) <- zip [1..] toks,
 
370
>                         n `elem` vars_used ]
 
371
>
 
372
>               extract t | t >= firstStartTok && t < fst_term = mkHappyOut t
 
373
>                         | otherwise                     = str "happyOutTok"
 
374
>
 
375
>               lt = length toks
 
376
 
 
377
>               this_absSynCon | coerce    = mkHappyIn nt
 
378
>                              | otherwise = makeAbsSynCon nt
379
379
 
380
380
%-----------------------------------------------------------------------------
381
381
The token conversion function.
382
382
 
383
383
>    produceTokenConverter
384
 
>       = case lexer' of { 
385
 
> 
386
 
>       Nothing ->
387
 
>         str "happyNewToken action sts stk [] =\n\t"
388
 
>       . eofAction "notHappyAtAll"
389
 
>       . str " []\n\n"
 
384
>       = case lexer' of {
 
385
>
 
386
>       Nothing ->
 
387
>         str "happyNewToken action sts stk [] =\n\t"
 
388
>       . eofAction "notHappyAtAll"
 
389
>       . str " []\n\n"
390
390
>       . str "happyNewToken action sts stk (tk:tks) =\n\t"
391
 
>       . str "let cont i = " . doAction . str " sts stk tks in\n\t"
392
 
>       . str "case tk of {\n\t"
393
 
>       . interleave ";\n\t" (map doToken token_rep)
394
 
>       . str "_ -> happyError' (tk:tks)\n\t"
395
 
>       . str "}\n\n"
 
391
>       . str "let cont i = " . doAction . str " sts stk tks in\n\t"
 
392
>       . str "case tk of {\n\t"
 
393
>       . interleave ";\n\t" (map doToken token_rep)
 
394
>       . str "_ -> happyError' (tk:tks)\n\t"
 
395
>       . str "}\n\n"
396
396
>       . str "happyError_ " . eofTok . str " tk tks = happyError' tks\n"
397
397
>       . str "happyError_ _ tk tks = happyError' (tk:tks)\n";
398
398
>             -- when the token is EOF, tk == _|_ (notHappyAtAll)
399
399
>             -- so we must not pass it to happyError'
400
400
 
401
 
>       Just (lexer'',eof') ->
402
 
>         str "happyNewToken action sts stk\n\t= "
403
 
>       . str lexer''
404
 
>       . str "(\\tk -> "
405
 
>       . str "\n\tlet cont i = "
406
 
>       . doAction
407
 
>       . str " sts stk in\n\t"
408
 
>       . str "case tk of {\n\t"
409
 
>       . str (eof' ++ " -> ")
410
 
>       . eofAction "tk" . str ";\n\t"
411
 
>       . interleave ";\n\t" (map doToken token_rep)
412
 
>       . str "_ -> happyError' tk\n\t"
413
 
>       . str "})\n\n"
 
401
>       Just (lexer'',eof') ->
 
402
>         str "happyNewToken action sts stk\n\t= "
 
403
>       . str lexer''
 
404
>       . str "(\\tk -> "
 
405
>       . str "\n\tlet cont i = "
 
406
>       . doAction
 
407
>       . str " sts stk in\n\t"
 
408
>       . str "case tk of {\n\t"
 
409
>       . str (eof' ++ " -> ")
 
410
>       . eofAction "tk" . str ";\n\t"
 
411
>       . interleave ";\n\t" (map doToken token_rep)
 
412
>       . str "_ -> happyError' tk\n\t"
 
413
>       . str "})\n\n"
414
414
>       . str "happyError_ " . eofTok . str " tk = happyError' tk\n"
415
415
>       . str "happyError_ _ tk = happyError' tk\n";
416
416
>             -- superfluous pattern match needed to force happyError_ to
417
417
>             -- have the correct type.
418
418
>       }
419
419
 
420
 
>       where 
 
420
>       where
421
421
 
422
 
>         eofAction tk =
423
 
>           (case target of
424
 
>               TargetArrayBased ->
425
 
>                 str "happyDoAction " . eofTok . strspace . str tk . str " action"
426
 
>               _ ->  str "action "     . eofTok . strspace . eofTok
427
 
>                   . strspace . str tk . str " (HappyState action)")
428
 
>            . str " sts stk"
429
 
>         eofTok = showInt (tokIndex eof)
430
 
>       
431
 
>         doAction = case target of
432
 
>           TargetArrayBased -> str "happyDoAction i tk action"
433
 
>           _   -> str "action i i tk (HappyState action)"
434
 
> 
435
 
>         doToken (i,tok) 
436
 
>               = str (removeDollarDollar tok)
437
 
>               . str " -> cont " 
438
 
>               . showInt (tokIndex i)
 
422
>         eofAction tk =
 
423
>           (case target of
 
424
>               TargetArrayBased ->
 
425
>                 str "happyDoAction " . eofTok . strspace . str tk . str " action"
 
426
>               _ ->  str "action "     . eofTok . strspace . eofTok
 
427
>                   . strspace . str tk . str " (HappyState action)")
 
428
>            . str " sts stk"
 
429
>         eofTok = showInt (tokIndex eof)
 
430
>
 
431
>         doAction = case target of
 
432
>           TargetArrayBased -> str "happyDoAction i tk action"
 
433
>           _   -> str "action i i tk (HappyState action)"
 
434
>
 
435
>         doToken (i,tok)
 
436
>               = str (removeDollarDollar tok)
 
437
>               . str " -> cont "
 
438
>               . showInt (tokIndex i)
439
439
 
440
440
Use a variable rather than '_' to replace '$$', so we can use it on
441
441
the left hand side of '@'.
442
442
 
443
 
>         removeDollarDollar xs = case mapDollarDollar xs of
444
 
>                                  Nothing -> xs
445
 
>                                  Just fn -> fn "happy_dollar_dollar"
 
443
>         removeDollarDollar xs = case mapDollarDollar xs of
 
444
>                                  Nothing -> xs
 
445
>                                  Just fn -> fn "happy_dollar_dollar"
446
446
 
447
447
>    mkHappyTerminalVar :: Int -> Int -> String -> String
448
 
>    mkHappyTerminalVar i t = 
 
448
>    mkHappyTerminalVar i t =
449
449
>     case tok_str_fn of
450
 
>       Nothing -> pat 
451
 
>       Just fn -> brack (fn (pat []))
 
450
>       Nothing -> pat
 
451
>       Just fn -> brack (fn (pat []))
452
452
>     where
453
 
>         tok_str_fn = case lookup t token_rep of
454
 
>                     Nothing -> Nothing
455
 
>                     Just str' -> mapDollarDollar str'
456
 
>         pat = mkHappyVar i
 
453
>         tok_str_fn = case lookup t token_rep of
 
454
>                     Nothing -> Nothing
 
455
>                     Just str' -> mapDollarDollar str'
 
456
>         pat = mkHappyVar i
457
457
 
458
 
>    tokIndex 
459
 
>       = case target of
460
 
>               TargetHaskell    -> id
461
 
>               TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2
462
 
>                       -- tokens adjusted to start at zero, see ARRAY_NOTES
 
458
>    tokIndex
 
459
>       = case target of
 
460
>               TargetHaskell    -> id
 
461
>               TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2
 
462
>                       -- tokens adjusted to start at zero, see ARRAY_NOTES
463
463
 
464
464
%-----------------------------------------------------------------------------
465
465
Action Tables.
484
484
 
485
485
State 345
486
486
 
487
 
        con -> conid .                                      (rule 186)
488
 
        qconid -> conid .                                   (rule 212)
 
487
        con -> conid .                                      (rule 186)
 
488
        qconid -> conid .                                   (rule 212)
489
489
 
490
 
        error          reduce using rule 212
491
 
        '{'            reduce using rule 186
492
 
        etc.
 
490
        error          reduce using rule 212
 
491
        '{'            reduce using rule 186
 
492
        etc.
493
493
 
494
494
we should make reduce_212 the default reduction here.  So the rules become:
495
495
 
496
 
   * if there is a production 
497
 
        error -> reduce_n
 
496
   * if there is a production
 
497
        error -> reduce_n
498
498
     then make reduce_n the default action.
499
499
   * if there is a non-reduce action for the error token, the default action
500
500
     for this state must be "fail".
509
509
none exists, we'll get a parse error.  In theory, we won't need the
510
510
machinery to discard states in the parser...
511
511
 
512
 
>    produceActionTable TargetHaskell 
513
 
>       = foldr (.) id (map (produceStateFunction goto) (assocs action))
514
 
>       
 
512
>    produceActionTable TargetHaskell
 
513
>       = foldr (.) id (map (produceStateFunction goto) (assocs action))
 
514
>
515
515
>    produceActionTable TargetArrayBased
516
 
>       = produceActionArray
517
 
>       . produceReduceArray
518
 
>       . str "happy_n_terms = " . shows n_terminals . str " :: Int\n"
519
 
>       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n"
 
516
>       = produceActionArray
 
517
>       . produceReduceArray
 
518
>       . str "happy_n_terms = " . shows n_terminals . str " :: Int\n"
 
519
>       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n"
520
520
 
521
521
>    produceStateFunction goto' (state, acts)
522
 
>       = foldr (.) id (map produceActions assocs_acts)
523
 
>       . foldr (.) id (map produceGotos   (assocs gotos))
524
 
>       . mkActionName state
525
 
>       . (if ghc
 
522
>       = foldr (.) id (map produceActions assocs_acts)
 
523
>       . foldr (.) id (map produceGotos   (assocs gotos))
 
524
>       . mkActionName state
 
525
>       . (if ghc
526
526
>              then str " x = happyTcHack x "
527
527
>              else str " _ = ")
528
 
>       . mkAction default_act
529
 
>       . str "\n\n"
530
 
>
531
 
>       where gotos = goto' ! state
532
 
>       
533
 
>             produceActions (_, LR'Fail{-'-}) = id
534
 
>             produceActions (t, action'@(LR'Reduce{-'-} _ _))
535
 
>                | action' == default_act = id
536
 
>                | otherwise = actionFunction t
537
 
>                            . mkAction action' . str "\n"
538
 
>             produceActions (t, action')
539
 
>               = actionFunction t
540
 
>               . mkAction action' . str "\n"
541
 
>               
542
 
>             produceGotos (t, Goto i)
543
 
>               = actionFunction t
544
 
>               . str "happyGoto " . mkActionName i . str "\n"
545
 
>             produceGotos (_, NoGoto) = id
546
 
>             
547
 
>             actionFunction t
548
 
>               = mkActionName state . strspace
549
 
>               . ('(' :) . showInt t
550
 
>               . str ") = "
551
 
>               
552
 
>             default_act = getDefault assocs_acts
553
 
>
554
 
>             assocs_acts = assocs acts
 
528
>       . mkAction default_act
 
529
>       . str "\n\n"
 
530
>
 
531
>       where gotos = goto' ! state
 
532
>
 
533
>             produceActions (_, LR'Fail{-'-}) = id
 
534
>             produceActions (t, action'@(LR'Reduce{-'-} _ _))
 
535
>                | action' == default_act = id
 
536
>                | otherwise = actionFunction t
 
537
>                            . mkAction action' . str "\n"
 
538
>             produceActions (t, action')
 
539
>               = actionFunction t
 
540
>               . mkAction action' . str "\n"
 
541
>
 
542
>             produceGotos (t, Goto i)
 
543
>               = actionFunction t
 
544
>               . str "happyGoto " . mkActionName i . str "\n"
 
545
>             produceGotos (_, NoGoto) = id
 
546
>
 
547
>             actionFunction t
 
548
>               = mkActionName state . strspace
 
549
>               . ('(' :) . showInt t
 
550
>               . str ") = "
 
551
>
 
552
>             default_act = getDefault assocs_acts
 
553
>
 
554
>             assocs_acts = assocs acts
555
555
 
556
556
action array indexed by (terminal * last_state) + state
557
557
 
558
558
>    produceActionArray
559
 
>       | ghc
560
 
>           = str "happyActOffsets :: HappyAddr\n"
561
 
>           . str "happyActOffsets = HappyA# \"" --"
562
 
>           . str (hexChars act_offs)
563
 
>           . str "\"#\n\n" --"
564
 
>       
565
 
>           . str "happyGotoOffsets :: HappyAddr\n"
566
 
>           . str "happyGotoOffsets = HappyA# \"" --"
567
 
>           . str (hexChars goto_offs)
568
 
>           . str "\"#\n\n"  --"
569
 
>
570
 
>           . str "happyDefActions :: HappyAddr\n"
571
 
>           . str "happyDefActions = HappyA# \"" --"
572
 
>           . str (hexChars defaults)
573
 
>           . str "\"#\n\n" --"
574
 
>       
575
 
>           . str "happyCheck :: HappyAddr\n"
576
 
>           . str "happyCheck = HappyA# \"" --"
577
 
>           . str (hexChars check)
578
 
>           . str "\"#\n\n" --"
579
 
>       
580
 
>           . str "happyTable :: HappyAddr\n"
581
 
>           . str "happyTable = HappyA# \"" --"
582
 
>           . str (hexChars table)
583
 
>           . str "\"#\n\n" --"
 
559
>       | ghc
 
560
>           = str "happyActOffsets :: HappyAddr\n"
 
561
>           . str "happyActOffsets = HappyA# \"" --"
 
562
>           . str (hexChars act_offs)
 
563
>           . str "\"#\n\n" --"
 
564
>
 
565
>           . str "happyGotoOffsets :: HappyAddr\n"
 
566
>           . str "happyGotoOffsets = HappyA# \"" --"
 
567
>           . str (hexChars goto_offs)
 
568
>           . str "\"#\n\n"  --"
 
569
>
 
570
>           . str "happyDefActions :: HappyAddr\n"
 
571
>           . str "happyDefActions = HappyA# \"" --"
 
572
>           . str (hexChars defaults)
 
573
>           . str "\"#\n\n" --"
 
574
>
 
575
>           . str "happyCheck :: HappyAddr\n"
 
576
>           . str "happyCheck = HappyA# \"" --"
 
577
>           . str (hexChars check)
 
578
>           . str "\"#\n\n" --"
 
579
>
 
580
>           . str "happyTable :: HappyAddr\n"
 
581
>           . str "happyTable = HappyA# \"" --"
 
582
>           . str (hexChars table)
 
583
>           . str "\"#\n\n" --"
584
584
 
585
 
>       | otherwise
586
 
>           = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n"
587
 
>           . str "happyActOffsets = Happy_Data_Array.listArray (0,"
588
 
>               . shows (n_states) . str ") (["
589
 
>           . interleave' "," (map shows act_offs)
590
 
>           . str "\n\t])\n\n"
591
 
>       
592
 
>           . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n"
593
 
>           . str "happyGotoOffsets = Happy_Data_Array.listArray (0,"
594
 
>               . shows (n_states) . str ") (["
595
 
>           . interleave' "," (map shows goto_offs)
596
 
>           . str "\n\t])\n\n"
597
 
>       
598
 
>           . str "happyDefActions :: Happy_Data_Array.Array Int Int\n"
599
 
>           . str "happyDefActions = Happy_Data_Array.listArray (0,"
600
 
>               . shows (n_states) . str ") (["
601
 
>           . interleave' "," (map shows defaults)
602
 
>           . str "\n\t])\n\n"
603
 
>       
604
 
>           . str "happyCheck :: Happy_Data_Array.Array Int Int\n"
605
 
>           . str "happyCheck = Happy_Data_Array.listArray (0,"
606
 
>               . shows table_size . str ") (["
607
 
>           . interleave' "," (map shows check)
608
 
>           . str "\n\t])\n\n"
609
 
>       
610
 
>           . str "happyTable :: Happy_Data_Array.Array Int Int\n"
611
 
>           . str "happyTable = Happy_Data_Array.listArray (0,"
612
 
>               . shows table_size . str ") (["
613
 
>           . interleave' "," (map shows table)
614
 
>           . str "\n\t])\n\n"
615
 
>       
 
585
>       | otherwise
 
586
>           = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n"
 
587
>           . str "happyActOffsets = Happy_Data_Array.listArray (0,"
 
588
>               . shows (n_states) . str ") (["
 
589
>           . interleave' "," (map shows act_offs)
 
590
>           . str "\n\t])\n\n"
 
591
>
 
592
>           . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n"
 
593
>           . str "happyGotoOffsets = Happy_Data_Array.listArray (0,"
 
594
>               . shows (n_states) . str ") (["
 
595
>           . interleave' "," (map shows goto_offs)
 
596
>           . str "\n\t])\n\n"
 
597
>
 
598
>           . str "happyDefActions :: Happy_Data_Array.Array Int Int\n"
 
599
>           . str "happyDefActions = Happy_Data_Array.listArray (0,"
 
600
>               . shows (n_states) . str ") (["
 
601
>           . interleave' "," (map shows defaults)
 
602
>           . str "\n\t])\n\n"
 
603
>
 
604
>           . str "happyCheck :: Happy_Data_Array.Array Int Int\n"
 
605
>           . str "happyCheck = Happy_Data_Array.listArray (0,"
 
606
>               . shows table_size . str ") (["
 
607
>           . interleave' "," (map shows check)
 
608
>           . str "\n\t])\n\n"
 
609
>
 
610
>           . str "happyTable :: Happy_Data_Array.Array Int Int\n"
 
611
>           . str "happyTable = Happy_Data_Array.listArray (0,"
 
612
>               . shows table_size . str ") (["
 
613
>           . interleave' "," (map shows table)
 
614
>           . str "\n\t])\n\n"
 
615
>
616
616
>    (_, last_state) = bounds action
617
617
>    n_states = last_state + 1
618
618
>    n_terminals = length terms
619
619
>    n_nonterminals = length nonterms - n_starts -- lose %starts
620
620
>
621
 
>    (act_offs,goto_offs,table,defaults,check) 
622
 
>       = mkTables action goto first_nonterm' fst_term
623
 
>               n_terminals n_nonterminals n_starts
 
621
>    (act_offs,goto_offs,table,defaults,check)
 
622
>       = mkTables action goto first_nonterm' fst_term
 
623
>               n_terminals n_nonterminals n_starts
624
624
>
625
625
>    table_size = length table - 1
626
626
>
627
627
>    produceReduceArray
628
 
>       = {- str "happyReduceArr :: Array Int a\n" -}
629
 
>         str "happyReduceArr = Happy_Data_Array.array ("
630
 
>               . shows (n_starts :: Int) -- omit the %start reductions
631
 
>               . str ", "
632
 
>               . shows n_rules
633
 
>               . str ") [\n"
634
 
>       . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])
635
 
>       . str "\n\t]\n\n"
 
628
>       = {- str "happyReduceArr :: Array Int a\n" -}
 
629
>         str "happyReduceArr = Happy_Data_Array.array ("
 
630
>               . shows (n_starts :: Int) -- omit the %start reductions
 
631
>               . str ", "
 
632
>               . shows n_rules
 
633
>               . str ") [\n"
 
634
>       . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])
 
635
>       . str "\n\t]\n\n"
636
636
 
637
637
>    n_rules = length prods - 1 :: Int
638
638
 
639
639
>    showInt i | ghc       = shows i . showChar '#'
640
 
>              | otherwise = shows i
 
640
>              | otherwise = shows i
641
641
 
642
642
This lets examples like:
643
643
 
644
 
        data HappyAbsSyn t1
645
 
                = HappyTerminal ( HaskToken )
646
 
                | HappyAbsSyn1 (  HaskExp  )
647
 
                | HappyAbsSyn2 (  HaskExp  )
648
 
                | HappyAbsSyn3 t1
 
644
        data HappyAbsSyn t1
 
645
                = HappyTerminal ( HaskToken )
 
646
                | HappyAbsSyn1 (  HaskExp  )
 
647
                | HappyAbsSyn2 (  HaskExp  )
 
648
                | HappyAbsSyn3 t1
649
649
 
650
650
*share* the defintion for ( HaskExp )
651
651
 
652
 
        data HappyAbsSyn t1
653
 
                = HappyTerminal ( HaskToken )
654
 
                | HappyAbsSyn1 (  HaskExp  )
655
 
                | HappyAbsSyn3 t1
 
652
        data HappyAbsSyn t1
 
653
                = HappyTerminal ( HaskToken )
 
654
                | HappyAbsSyn1 (  HaskExp  )
 
655
                | HappyAbsSyn3 t1
656
656
 
657
657
... cuting down on the work that the type checker has to do.
658
658
 
661
661
outlaw them inside { }
662
662
 
663
663
>    nt_types_index :: Array Int Int
664
 
>    nt_types_index = array (bounds nt_types) 
665
 
>                       [ (a, fn a b) | (a, b) <- assocs nt_types ]
 
664
>    nt_types_index = array (bounds nt_types)
 
665
>                       [ (a, fn a b) | (a, b) <- assocs nt_types ]
666
666
>     where
667
 
>       fn n Nothing = n
668
 
>       fn _ (Just a) = case lookup a assoc_list of
669
 
>                         Just v -> v
670
 
>                         Nothing -> error ("cant find an item in list")
671
 
>       assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ]
 
667
>       fn n Nothing = n
 
668
>       fn _ (Just a) = case lookup a assoc_list of
 
669
>                         Just v -> v
 
670
>                         Nothing -> error ("cant find an item in list")
 
671
>       assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ]
672
672
 
673
673
>    makeAbsSynCon = mkAbsSynCon nt_types_index
674
674
 
675
675
 
676
676
>    produceIdentityStuff | use_monad = id
677
677
>     | imported_identity' =
678
 
>            str "type HappyIdentity = Identity\n"
679
 
>          . str "happyIdentity = Identity\n"
680
 
>          . str "happyRunIdentity = runIdentity\n\n"
 
678
>            str "type HappyIdentity = Identity\n"
 
679
>          . str "happyIdentity = Identity\n"
 
680
>          . str "happyRunIdentity = runIdentity\n\n"
681
681
>     | otherwise =
682
 
>            str "newtype HappyIdentity a = HappyIdentity a\n"
683
 
>          . str "happyIdentity = HappyIdentity\n"
684
 
>          . str "happyRunIdentity (HappyIdentity a) = a\n\n"
685
 
>          . str "instance Monad HappyIdentity where\n"
686
 
>          . str "    return = HappyIdentity\n"
687
 
>          . str "    (HappyIdentity p) >>= q = q p\n\n"
 
682
>            str "newtype HappyIdentity a = HappyIdentity a\n"
 
683
>          . str "happyIdentity = HappyIdentity\n"
 
684
>          . str "happyRunIdentity (HappyIdentity a) = a\n\n"
 
685
>          . str "instance Monad HappyIdentity where\n"
 
686
>          . str "    return = HappyIdentity\n"
 
687
>          . str "    (HappyIdentity p) >>= q = q p\n\n"
688
688
 
689
689
MonadStuff:
690
690
 
691
691
  - with no %monad or %lexer:
692
692
 
693
 
        happyThen    :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
694
 
        happyReturn  :: () => a -> HappyIdentity a
695
 
        happyThen1   m k tks = happyThen m (\a -> k a tks)
696
 
        happyReturn1 = \a tks -> happyReturn a
 
693
        happyThen    :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
 
694
        happyReturn  :: () => a -> HappyIdentity a
 
695
        happyThen1   m k tks = happyThen m (\a -> k a tks)
 
696
        happyReturn1 = \a tks -> happyReturn a
697
697
 
698
698
  - with %monad:
699
699
 
700
 
        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
701
 
        happyReturn  :: CONTEXT => a -> P a
702
 
        happyThen1   m k tks = happyThen m (\a -> k a tks)
703
 
        happyReturn1 = \a tks -> happyReturn a
 
700
        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
 
701
        happyReturn  :: CONTEXT => a -> P a
 
702
        happyThen1   m k tks = happyThen m (\a -> k a tks)
 
703
        happyReturn1 = \a tks -> happyReturn a
704
704
 
705
705
  - with %monad & %lexer:
706
706
 
707
 
        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
708
 
        happyReturn  :: CONTEXT => a -> P a
709
 
        happyThen1   = happyThen
710
 
        happyReturn1 = happyReturn
 
707
        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
 
708
        happyReturn  :: CONTEXT => a -> P a
 
709
        happyThen1   = happyThen
 
710
        happyReturn1 = happyReturn
711
711
 
712
712
 
713
713
>    produceMonadStuff =
714
 
>            let pcont = str monad_context in
715
 
>            let pty = str monad_tycon in
716
 
>            str "happyThen :: " . pcont . str " => " . pty
717
 
>          . str " a -> (a -> "  . pty
718
 
>          . str " b) -> " . pty . str " b\n"
719
 
>          . str "happyThen = " . brack monad_then . nl
720
 
>          . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n"
721
 
>          . str "happyReturn = " . brack monad_return . nl
722
 
>          . case lexer' of
723
 
>               Nothing ->
724
 
>                  str "happyThen1 m k tks = (" . str monad_then 
725
 
>                . str ") m (\\a -> k a tks)\n"
726
 
>                . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n"
727
 
>                . str "happyReturn1 = \\a tks -> " . brack monad_return
728
 
>                . str " a\n"
729
 
>                . str "happyError' :: " . str monad_context . str " => ["
730
 
>                . token
731
 
>                . str "] -> "
732
 
>                . str monad_tycon
733
 
>                . str " a\n"
734
 
>                . str "happyError' = "
735
 
>                . str (if use_monad then "" else "HappyIdentity . ")
736
 
>                . errorHandler
737
 
>                . str "\n\n"
738
 
>               _ ->
739
 
>                  str "happyThen1 = happyThen\n"
740
 
>                . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n"
741
 
>                . str "happyReturn1 = happyReturn\n"
742
 
>                . str "happyError' :: " . str monad_context . str " => "
743
 
>                                        . token . str " -> " 
744
 
>                . str monad_tycon
745
 
>                . str " a\n"
746
 
>                . str "happyError' tk = "
747
 
>                . str (if use_monad then "" else "HappyIdentity ")
748
 
>                . errorHandler . str " tk\n"
749
 
>                . str "\n"
 
714
>            let pcont = str monad_context in
 
715
>            let pty = str monad_tycon in
 
716
>            str "happyThen :: " . pcont . str " => " . pty
 
717
>          . str " a -> (a -> "  . pty
 
718
>          . str " b) -> " . pty . str " b\n"
 
719
>          . str "happyThen = " . brack monad_then . nl
 
720
>          . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n"
 
721
>          . str "happyReturn = " . brack monad_return . nl
 
722
>          . case lexer' of
 
723
>               Nothing ->
 
724
>                  str "happyThen1 m k tks = (" . str monad_then
 
725
>                . str ") m (\\a -> k a tks)\n"
 
726
>                . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n"
 
727
>                . str "happyReturn1 = \\a tks -> " . brack monad_return
 
728
>                . str " a\n"
 
729
>                . str "happyError' :: " . str monad_context . str " => ["
 
730
>                . token
 
731
>                . str "] -> "
 
732
>                . str monad_tycon
 
733
>                . str " a\n"
 
734
>                . str "happyError' = "
 
735
>                . str (if use_monad then "" else "HappyIdentity . ")
 
736
>                . errorHandler
 
737
>                . str "\n\n"
 
738
>               _ ->
 
739
>                  str "happyThen1 = happyThen\n"
 
740
>                . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n"
 
741
>                . str "happyReturn1 = happyReturn\n"
 
742
>                . str "happyError' :: " . str monad_context . str " => "
 
743
>                                        . token . str " -> "
 
744
>                . str monad_tycon
 
745
>                . str " a\n"
 
746
>                . str "happyError' tk = "
 
747
>                . str (if use_monad then "" else "HappyIdentity ")
 
748
>                . errorHandler . str " tk\n"
 
749
>                . str "\n"
750
750
 
751
751
An error handler specified with %error is passed the current token
752
752
when used with %lexer, but happyError (the old way but kept for
753
753
compatibility) is not passed the current token.
754
754
 
755
 
>    errorHandler = 
756
 
>       case error_handler' of
757
 
>               Just h  -> str h
758
 
>               Nothing -> case lexer' of 
759
 
>                               Nothing -> str "happyError"
760
 
>                               Just _  -> str "(\\token -> happyError)"
 
755
>    errorHandler =
 
756
>       case error_handler' of
 
757
>               Just h  -> str h
 
758
>               Nothing -> case lexer' of
 
759
>                               Nothing -> str "happyError"
 
760
>                               Just _  -> str "(\\token -> happyError)"
761
761
 
762
762
>    reduceArrElem n
763
763
>      = str "\t(" . shows n . str " , "
767
767
-- Produce the parser entry and exit points
768
768
 
769
769
>    produceEntries
770
 
>       = interleave "\n\n" (map produceEntry (zip starts' [0..]))
 
770
>       = interleave "\n\n" (map produceEntry (zip starts' [0..]))
771
771
>       . if null attributes' then id else produceAttrEntries starts'
772
772
 
773
773
>    produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no)
774
774
>       = (if null attributes' then str name else str "do_" . str name)
775
 
>       . maybe_tks
776
 
>       . str " = "
777
 
>       . str unmonad
778
 
>       . str "happySomeParser where\n"
779
 
>       . str "  happySomeParser = happyThen (happyParse "
780
 
>       . case target of
781
 
>            TargetHaskell -> str "action_" . shows no
782
 
>            TargetArrayBased
783
 
>                | ghc       -> shows no . str "#"
784
 
>                | otherwise -> shows no                        
785
 
>       . maybe_tks
786
 
>       . str ") "
787
 
>       . brack' (if coerce 
788
 
>                    then str "\\x -> happyReturn (happyOut" 
789
 
>                       . shows accept_nonterm . str " x)"
790
 
>                    else str "\\x -> case x of {HappyAbsSyn" 
791
 
>                       . shows (nt_types_index ! accept_nonterm)
792
 
>                       . str " z -> happyReturn z; _other -> notHappyAtAll }"
793
 
>                )
 
775
>       . maybe_tks
 
776
>       . str " = "
 
777
>       . str unmonad
 
778
>       . str "happySomeParser where\n"
 
779
>       . str "  happySomeParser = happyThen (happyParse "
 
780
>       . case target of
 
781
>            TargetHaskell -> str "action_" . shows no
 
782
>            TargetArrayBased
 
783
>                | ghc       -> shows no . str "#"
 
784
>                | otherwise -> shows no
 
785
>       . maybe_tks
 
786
>       . str ") "
 
787
>       . brack' (if coerce
 
788
>                    then str "\\x -> happyReturn (happyOut"
 
789
>                       . shows accept_nonterm . str " x)"
 
790
>                    else str "\\x -> case x of {HappyAbsSyn"
 
791
>                       . shows (nt_types_index ! accept_nonterm)
 
792
>                       . str " z -> happyReturn z; _other -> notHappyAtAll }"
 
793
>                )
794
794
>     where
795
 
>       maybe_tks | isNothing lexer' = str " tks"
796
 
>                 | otherwise = id
797
 
>       unmonad | use_monad = ""
798
 
>                 | otherwise = "happyRunIdentity "
 
795
>       maybe_tks | isNothing lexer' = str " tks"
 
796
>                 | otherwise = id
 
797
>       unmonad | use_monad = ""
 
798
>                 | otherwise = "happyRunIdentity "
799
799
 
800
800
>    produceAttrEntries starts''
801
801
>       = interleave "\n\n" (map f starts'')
809
809
>       defaultAttr = fst (head attributes')
810
810
>
811
811
>       monadAndLexerAE name
812
 
>         = str name . str " = " 
 
812
>         = str name . str " = "
813
813
>         . str "do { "
814
814
>         . str "f <- do_" . str name . str "; "
815
815
>         . str "let { (conds,attrs) = f happyEmptyAttrs } in do { "
835
835
 
836
836
> produceAttributes :: [(String, String)] -> String -> String -> String
837
837
> produceAttributes [] _ = id
838
 
> produceAttributes attrs attributeType 
 
838
> produceAttributes attrs attributeType
839
839
>     = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl
840
840
>     . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl
841
841
 
854
854
 
855
855
> produceStrict :: Bool -> String -> String
856
856
> produceStrict strict
857
 
>       | strict    = str "happySeq = happyDoSeq\n\n"
858
 
>       | otherwise = str "happySeq = happyDontSeq\n\n"
 
857
>       | strict    = str "happySeq = happyDoSeq\n\n"
 
858
>       | otherwise = str "happySeq = happyDontSeq\n\n"
859
859
 
860
860
-----------------------------------------------------------------------------
861
861
Replace all the $n variables with happy_vars, and return a list of all the
862
862
vars used in this piece of code.
863
863
 
864
864
> actionVal :: LRAction -> Int
865
 
> actionVal (LR'Shift  state _) = state + 1
866
 
> actionVal (LR'Reduce rule _)  = -(rule + 1)
867
 
> actionVal LR'Accept           = -1
868
 
> actionVal (LR'Multiple _ a)   = actionVal a
869
 
> actionVal LR'Fail             = 0
870
 
> actionVal LR'MustFail         = 0
 
865
> actionVal (LR'Shift  state _) = state + 1
 
866
> actionVal (LR'Reduce rule _)  = -(rule + 1)
 
867
> actionVal LR'Accept           = -1
 
868
> actionVal (LR'Multiple _ a)   = actionVal a
 
869
> actionVal LR'Fail             = 0
 
870
> actionVal LR'MustFail         = 0
871
871
 
872
872
> mkAction :: LRAction -> String -> String
873
 
> mkAction (LR'Shift i _)       = str "happyShift " . mkActionName i
874
 
> mkAction LR'Accept            = str "happyAccept"
875
 
> mkAction LR'Fail              = str "happyFail"
876
 
> mkAction LR'MustFail          = str "happyFail"
877
 
> mkAction (LR'Reduce i _)      = str "happyReduce_" . shows i
878
 
> mkAction (LR'Multiple _ a)    = mkAction a
 
873
> mkAction (LR'Shift i _)       = str "happyShift " . mkActionName i
 
874
> mkAction LR'Accept            = str "happyAccept"
 
875
> mkAction LR'Fail              = str "happyFail"
 
876
> mkAction LR'MustFail          = str "happyFail"
 
877
> mkAction (LR'Reduce i _)      = str "happyReduce_" . shows i
 
878
> mkAction (LR'Multiple _ a)    = mkAction a
879
879
 
880
880
> mkActionName :: Int -> String -> String
881
 
> mkActionName i                = str "action_" . shows i
 
881
> mkActionName i                = str "action_" . shows i
882
882
 
883
883
See notes under "Action Tables" above for some subtleties in this function.
884
884
 
887
887
>   -- pick out the action for the error token, if any
888
888
>   case [ act | (e, act) <- actions, e == errorTok ] of
889
889
>
890
 
>       -- use error reduction as the default action, if there is one.
891
 
>       act@(LR'Reduce _ _) : _                 -> act
892
 
>       act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act
893
 
>
894
 
>       -- if the error token is shifted or otherwise, don't generate
895
 
>       --  a default action.  This is *important*!
896
 
>       (act : _) | act /= LR'Fail -> LR'Fail
897
 
>
898
 
>       -- no error actions, pick a reduce to be the default.
899
 
>       _      -> case reduces of
900
 
>                     [] -> LR'Fail
901
 
>                     (act:_) -> act    -- pick the first one we see for now
902
 
>
903
 
>   where reduces 
904
 
>           =  [ act | (_,act@(LR'Reduce _ _)) <- actions ]
905
 
>           ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ]
 
890
>       -- use error reduction as the default action, if there is one.
 
891
>       act@(LR'Reduce _ _) : _                 -> act
 
892
>       act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act
 
893
>
 
894
>       -- if the error token is shifted or otherwise, don't generate
 
895
>       --  a default action.  This is *important*!
 
896
>       (act : _) | act /= LR'Fail -> LR'Fail
 
897
>
 
898
>       -- no error actions, pick a reduce to be the default.
 
899
>       _      -> case reduces of
 
900
>                     [] -> LR'Fail
 
901
>                     (act:_) -> act    -- pick the first one we see for now
 
902
>
 
903
>   where reduces
 
904
>           =  [ act | (_,act@(LR'Reduce _ _)) <- actions ]
 
905
>           ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ]
906
906
 
907
907
-----------------------------------------------------------------------------
908
908
-- Generate packed parsing tables.
914
914
--     Offset within happyTable of gotos for state
915
915
 
916
916
-- happyTable
917
 
--      Combined action/goto table
 
917
--      Combined action/goto table
918
918
 
919
919
-- happyDefAction ! state
 
920
--      Default action for state
920
921
 
921
922
-- happyCheck
922
 
--      Indicates whether we should use the default action for state
 
923
--      Indicates whether we should use the default action for state
923
924
 
924
925
 
925
926
-- the table is laid out such that the action for a given state & token
926
927
-- can be found by:
927
928
--
928
929
--        off    = happyActOff ! state
929
 
--        off_i  = off + token
930
 
--        check  | off_i => 0 = (happyCheck ! off_i) == token
931
 
--               | otherwise  = False
932
 
--        action | check      = happyTable ! off_i
933
 
--               | otherwise  = happyDefAaction ! off_i
 
930
--        off_i  = off + token
 
931
--        check  | off_i => 0 = (happyCheck ! off_i) == token
 
932
--               | otherwise  = False
 
933
--        action | check      = happyTable ! off_i
 
934
--               | otherwise  = happyDefAaction ! off_i
934
935
 
935
936
 
936
937
-- figure out the default action for each state.  This will leave some
950
950
-- from above.
951
951
 
952
952
 
953
 
> mkTables 
954
 
>        :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int ->
955
 
>        ([Int]         -- happyActOffsets
956
 
>        ,[Int]         -- happyGotoOffsets
957
 
>        ,[Int]         -- happyTable
958
 
>        ,[Int]         -- happyDefAction
959
 
>        ,[Int]         -- happyCheck
960
 
>        )
 
953
> mkTables
 
954
>        :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int ->
 
955
>        ([Int]         -- happyActOffsets
 
956
>        ,[Int]         -- happyGotoOffsets
 
957
>        ,[Int]         -- happyTable
 
958
>        ,[Int]         -- happyDefAction
 
959
>        ,[Int]         -- happyCheck
 
960
>        )
961
961
>
962
 
> mkTables action goto first_nonterm' fst_term 
963
 
>               n_terminals n_nonterminals n_starts
964
 
>  = ( elems act_offs, 
965
 
>      elems goto_offs, 
 
962
> mkTables action goto first_nonterm' fst_term
 
963
>               n_terminals n_nonterminals n_starts
 
964
>  = ( elems act_offs,
 
965
>      elems goto_offs,
966
966
>      take max_off (elems table),
967
 
>      def_actions, 
 
967
>      def_actions,
968
968
>      take max_off (elems check)
969
969
>   )
970
 
>  where 
971
 
>
972
 
>        (table,check,act_offs,goto_offs,max_off) 
973
 
>                = runST (genTables (length actions) max_token sorted_actions)
974
 
>        
975
 
>        -- the maximum token number used in the parser
976
 
>        max_token = max n_terminals (n_starts+n_nonterminals) - 1
977
 
>
978
 
>        def_actions = map (\(_,_,def,_,_,_) -> def) actions
979
 
>
980
 
>        actions :: [TableEntry]
981
 
>        actions = 
982
 
>                [ (ActionEntry,
983
 
>                   state,
984
 
>                   actionVal default_act,
985
 
>                   if null acts'' then 0 
986
 
>                        else fst (last acts'') - fst (head acts''),
987
 
>                   length acts'',
988
 
>                   acts'')
989
 
>                | (state, acts) <- assocs action,
990
 
>                  let (err:_dummy:vec) = assocs acts
991
 
>                      vec' = drop (n_starts+n_nonterminals) vec
992
 
>                      acts' = filter (notFail) (err:vec')
993
 
>                      default_act = getDefault acts'
994
 
>                      acts'' = mkActVals acts' default_act
995
 
>                ]
996
 
>
997
 
>        -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0).
998
 
>        --  (see ARRAY_NOTES)
999
 
>        adjust token | token == errorTok = 0
1000
 
>                     | otherwise         = token - fst_term + 1
1001
 
>
1002
 
>        mkActVals assocs' default_act =
1003
 
>                [ (adjust token, actionVal act) 
1004
 
>                | (token, act) <- assocs'
1005
 
>                , act /= default_act ]
1006
 
>
1007
 
>        gotos :: [TableEntry]
1008
 
>        gotos = [ (GotoEntry,
1009
 
>                   state, 0, 
1010
 
>                   if null goto_vals then 0 
1011
 
>                        else fst (last goto_vals) - fst (head goto_vals),
1012
 
>                   length goto_vals,
1013
 
>                   goto_vals
1014
 
>                  )
1015
 
>                | (state, goto_arr) <- assocs goto,
1016
 
>                let goto_vals = mkGotoVals (assocs goto_arr)
1017
 
>                ]
1018
 
>
1019
 
>        -- adjust nonterminals by -first_nonterm', so they start at zero
1020
 
>        --  (see ARRAY_NOTES)
1021
 
>        mkGotoVals assocs' =
1022
 
>                [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ]
1023
 
>
1024
 
>        sorted_actions = reverse (sortBy cmp_state (actions++gotos))
1025
 
>        cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_)
1026
 
>                | width1 < width2  = LT
1027
 
>                | width1 == width2 = compare tally1 tally2
1028
 
>                | otherwise = GT
 
970
>  where
 
971
>
 
972
>        (table,check,act_offs,goto_offs,max_off)
 
973
>                = runST (genTables (length actions) max_token sorted_actions)
 
974
>
 
975
>        -- the maximum token number used in the parser
 
976
>        max_token = max n_terminals (n_starts+n_nonterminals) - 1
 
977
>
 
978
>        def_actions = map (\(_,_,def,_,_,_) -> def) actions
 
979
>
 
980
>        actions :: [TableEntry]
 
981
>        actions =
 
982
>                [ (ActionEntry,
 
983
>                   state,
 
984
>                   actionVal default_act,
 
985
>                   if null acts'' then 0
 
986
>                        else fst (last acts'') - fst (head acts''),
 
987
>                   length acts'',
 
988
>                   acts'')
 
989
>                | (state, acts) <- assocs action,
 
990
>                  let (err:_dummy:vec) = assocs acts
 
991
>                      vec' = drop (n_starts+n_nonterminals) vec
 
992
>                      acts' = filter (notFail) (err:vec')
 
993
>                      default_act = getDefault acts'
 
994
>                      acts'' = mkActVals acts' default_act
 
995
>                ]
 
996
>
 
997
>        -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0).
 
998
>        --  (see ARRAY_NOTES)
 
999
>        adjust token | token == errorTok = 0
 
1000
>                     | otherwise         = token - fst_term + 1
 
1001
>
 
1002
>        mkActVals assocs' default_act =
 
1003
>                [ (adjust token, actionVal act)
 
1004
>                | (token, act) <- assocs'
 
1005
>                , act /= default_act ]
 
1006
>
 
1007
>        gotos :: [TableEntry]
 
1008
>        gotos = [ (GotoEntry,
 
1009
>                   state, 0,
 
1010
>                   if null goto_vals then 0
 
1011
>                        else fst (last goto_vals) - fst (head goto_vals),
 
1012
>                   length goto_vals,
 
1013
>                   goto_vals
 
1014
>                  )
 
1015
>                | (state, goto_arr) <- assocs goto,
 
1016
>                let goto_vals = mkGotoVals (assocs goto_arr)
 
1017
>                ]
 
1018
>
 
1019
>        -- adjust nonterminals by -first_nonterm', so they start at zero
 
1020
>        --  (see ARRAY_NOTES)
 
1021
>        mkGotoVals assocs' =
 
1022
>                [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ]
 
1023
>
 
1024
>        sorted_actions = reverse (sortBy cmp_state (actions++gotos))
 
1025
>        cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_)
 
1026
>                | width1 < width2  = LT
 
1027
>                | width1 == width2 = compare tally1 tally2
 
1028
>                | otherwise = GT
1029
1029
 
1030
1030
> data ActionOrGoto = ActionEntry | GotoEntry
1031
1031
> type TableEntry = (ActionOrGoto,
1032
 
>                       Int{-stateno-},
1033
 
>                       Int{-default-},
1034
 
>                       Int{-width-},
1035
 
>                       Int{-tally-},
1036
 
>                       [(Int,Int)])
 
1032
>                       Int{-stateno-},
 
1033
>                       Int{-default-},
 
1034
>                       Int{-width-},
 
1035
>                       Int{-tally-},
 
1036
>                       [(Int,Int)])
1037
1037
 
1038
1038
> genTables
1039
 
>        :: Int                         -- number of actions
1040
 
>        -> Int                         -- maximum token no.
1041
 
>        -> [TableEntry]                -- entries for the table
1042
 
>        -> ST s (UArray Int Int,       -- table
1043
 
>                 UArray Int Int,       -- check
1044
 
>                 UArray Int Int,       -- action offsets
1045
 
>                 UArray Int Int,       -- goto offsets
1046
 
>                 Int                   -- highest offset in table
1047
 
>           )
 
1039
>        :: Int                         -- number of actions
 
1040
>        -> Int                         -- maximum token no.
 
1041
>        -> [TableEntry]                -- entries for the table
 
1042
>        -> ST s (UArray Int Int,       -- table
 
1043
>                 UArray Int Int,       -- check
 
1044
>                 UArray Int Int,       -- action offsets
 
1045
>                 UArray Int Int,       -- goto offsets
 
1046
>                 Int                   -- highest offset in table
 
1047
>           )
1048
1048
>
1049
1049
> genTables n_actions max_token entries = do
1050
1050
>
1054
1054
>   goto_offs  <- newArray (0, n_actions) 0
1055
1055
>   off_arr    <- newArray (-max_token, mAX_TABLE_SIZE) 0
1056
1056
>
1057
 
>   max_off <- genTables' table check act_offs goto_offs 
1058
 
>                       off_arr entries max_token
 
1057
>   max_off <- genTables' table check act_offs goto_offs
 
1058
>                       off_arr entries max_token
1059
1059
>
1060
1060
>   table'     <- freeze table
1061
1061
>   check'     <- freeze check
1064
1064
>   return (table',check',act_offs',goto_offs',max_off+1)
1065
1065
 
1066
1066
>   where
1067
 
>        n_states = n_actions - 1
1068
 
>        mAX_TABLE_SIZE = n_states * (max_token + 1)
 
1067
>        n_states = n_actions - 1
 
1068
>        mAX_TABLE_SIZE = n_states * (max_token + 1)
1069
1069
 
1070
1070
 
1071
1071
> genTables'
1072
 
>        :: STUArray s Int Int          -- table
1073
 
>        -> STUArray s Int Int          -- check
1074
 
>        -> STUArray s Int Int          -- action offsets
1075
 
>        -> STUArray s Int Int          -- goto offsets
1076
 
>        -> STUArray s Int Int          -- offset array
1077
 
>        -> [TableEntry]                -- entries for the table
1078
 
>        -> Int                         -- maximum token no.
1079
 
>        -> ST s Int                    -- highest offset in table
 
1072
>        :: STUArray s Int Int          -- table
 
1073
>        -> STUArray s Int Int          -- check
 
1074
>        -> STUArray s Int Int          -- action offsets
 
1075
>        -> STUArray s Int Int          -- goto offsets
 
1076
>        -> STUArray s Int Int          -- offset array
 
1077
>        -> [TableEntry]                -- entries for the table
 
1078
>        -> Int                         -- maximum token no.
 
1079
>        -> ST s Int                    -- highest offset in table
1080
1080
>
1081
1081
> genTables' table check act_offs goto_offs off_arr entries max_token
1082
 
>       = fit_all entries 0 1
 
1082
>       = fit_all entries 0 1
1083
1083
>   where
1084
1084
>
1085
 
>        fit_all [] max_off _ = return max_off
1086
 
>        fit_all (s:ss) max_off fst_zero = do
1087
 
>          (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero
1088
 
>          ss' <- same_states s ss off
1089
 
>          writeArray off_arr off 1
1090
 
>          fit_all ss' new_max_off new_fst_zero
1091
 
>
1092
 
>        -- try to merge identical states.  We only try the next state(s)
1093
 
>        -- in the list, but the list is kind-of sorted so we shouldn't
1094
 
>        -- miss too many.
1095
 
>        same_states _ [] _ = return []
1096
 
>        same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off
1097
 
>          | acts == acts' = do writeArray (which_off e) no off
1098
 
>                               same_states s ss' off
1099
 
>          | otherwise = return ss
1100
 
>  
1101
 
>        which_off ActionEntry = act_offs
1102
 
>        which_off GotoEntry   = goto_offs
1103
 
>
1104
 
>        -- fit a vector into the table.  Return the offset of the vector,
1105
 
>        -- the maximum offset used in the table, and the offset of the first
1106
 
>        -- entry in the table (used to speed up the lookups a bit).
1107
 
>        fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero)
1108
 
>
1109
 
>        fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_))
1110
 
>           max_off fst_zero = do
1111
 
>                -- start at offset 1 in the table: all the empty states
1112
 
>                -- (states with just a default reduction) are mapped to
1113
 
>                -- offset zero.
1114
 
>          off <- findFreeOffset (-t+fst_zero) check off_arr state
1115
 
>          let new_max_off | furthest_right > max_off = furthest_right
1116
 
>                          | otherwise                = max_off
1117
 
>              furthest_right = off + max_token
1118
 
>
1119
 
>          -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do
1120
 
>
1121
 
>          writeArray (which_off act_or_goto) state_no off
1122
 
>          addState off table check state
1123
 
>          new_fst_zero <- findFstFreeSlot check fst_zero
1124
 
>          return (off, new_max_off, new_fst_zero)
 
1085
>        fit_all [] max_off _ = return max_off
 
1086
>        fit_all (s:ss) max_off fst_zero = do
 
1087
>          (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero
 
1088
>          ss' <- same_states s ss off
 
1089
>          writeArray off_arr off 1
 
1090
>          fit_all ss' new_max_off new_fst_zero
 
1091
>
 
1092
>        -- try to merge identical states.  We only try the next state(s)
 
1093
>        -- in the list, but the list is kind-of sorted so we shouldn't
 
1094
>        -- miss too many.
 
1095
>        same_states _ [] _ = return []
 
1096
>        same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off
 
1097
>          | acts == acts' = do writeArray (which_off e) no off
 
1098
>                               same_states s ss' off
 
1099
>          | otherwise = return ss
 
1100
>
 
1101
>        which_off ActionEntry = act_offs
 
1102
>        which_off GotoEntry   = goto_offs
 
1103
>
 
1104
>        -- fit a vector into the table.  Return the offset of the vector,
 
1105
>        -- the maximum offset used in the table, and the offset of the first
 
1106
>        -- entry in the table (used to speed up the lookups a bit).
 
1107
>        fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero)
 
1108
>
 
1109
>        fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_))
 
1110
>           max_off fst_zero = do
 
1111
>                -- start at offset 1 in the table: all the empty states
 
1112
>                -- (states with just a default reduction) are mapped to
 
1113
>                -- offset zero.
 
1114
>          off <- findFreeOffset (-t+fst_zero) check off_arr state
 
1115
>          let new_max_off | furthest_right > max_off = furthest_right
 
1116
>                          | otherwise                = max_off
 
1117
>              furthest_right = off + max_token
 
1118
>
 
1119
>          -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do
 
1120
>
 
1121
>          writeArray (which_off act_or_goto) state_no off
 
1122
>          addState off table check state
 
1123
>          new_fst_zero <- findFstFreeSlot check fst_zero
 
1124
>          return (off, new_max_off, new_fst_zero)
1125
1125
 
1126
1126
When looking for a free offest in the table, we use the 'check' table
1127
1127
rather than the main table.  The check table starts off with (-1) in
1128
1128
every slot, because that's the only thing that doesn't overlap with
1129
 
any tokens (non-terminals start at 0, terminals start at 1).  
 
1129
any tokens (non-terminals start at 0, terminals start at 1).
1130
1130
 
1131
1131
Because we use 0 for LR'MustFail as well as LR'Fail, we can't check
1132
1132
for free offsets in the main table because we can't tell whether a
1146
1146
>   ok <- fits off state table
1147
1147
>   if not ok then try_next else return off
1148
1148
>  where
1149
 
>       try_next = findFreeOffset (off+1) table off_arr state
 
1149
>       try_next = findFreeOffset (off+1) table off_arr state
1150
1150
 
1151
1151
 
1152
1152
> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool
1154
1154
> fits off ((t,_):rest) table = do
1155
1155
>   i <- readArray table (off+t)
1156
1156
>   if i /= -1 then return False
1157
 
>              else fits off rest table
 
1157
>              else fits off rest table
1158
1158
 
1159
1159
> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)]
1160
1160
>          -> ST s ()
1170
1170
 
1171
1171
> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int
1172
1172
> findFstFreeSlot table n = do
1173
 
>        i <- readArray table n
1174
 
>        if i == -1 then return n
1175
 
>                   else findFstFreeSlot table (n+1)
 
1173
>        i <- readArray table n
 
1174
>        if i == -1 then return n
 
1175
>                   else findFstFreeSlot table (n+1)
1176
1176
 
1177
1177
-----------------------------------------------------------------------------
1178
1178
-- Misc.
1179
1179
 
1180
1180
> comment :: String
1181
 
> comment = 
1182
 
>         "-- parser produced by Happy Version " ++ showVersion version ++ "\n\n"
 
1181
> comment =
 
1182
>         "-- parser produced by Happy Version " ++ showVersion version ++ "\n\n"
1183
1183
 
1184
1184
> mkAbsSynCon :: Array Int Int -> Int -> String -> String
1185
 
> mkAbsSynCon fx t      = str "HappyAbsSyn"   . shows (fx ! t)
 
1185
> mkAbsSynCon fx t      = str "HappyAbsSyn"   . shows (fx ! t)
1186
1186
 
1187
1187
> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String
1188
 
> mkHappyVar n          = str "happy_var_"    . shows n
1189
 
> mkReduceFun n         = str "happyReduce_"  . shows n
1190
 
> mkDummyVar n          = str "happy_x_"      . shows n
 
1188
> mkHappyVar n          = str "happy_var_"    . shows n
 
1189
> mkReduceFun n         = str "happyReduce_"  . shows n
 
1190
> mkDummyVar n          = str "happy_x_"      . shows n
1191
1191
 
1192
1192
> mkHappyIn, mkHappyOut :: Int -> String -> String
1193
1193
> mkHappyIn n           = str "happyIn"  . shows n
1216
1216
 
1217
1217
> hexDig :: Int -> Char
1218
1218
> hexDig i | i <= 9    = chr (i + ord '0')
1219
 
>          | otherwise = chr (i - 10 + ord 'a')
 
1219
>          | otherwise = chr (i - 10 + ord 'a')