[project @ 1997-05-26 03:33:27 by sof]
[ghc-hetmet.git] / ghc / compiler / rename / ParseUnfolding.y
1 {
2 #include "HsVersions.h"
3 module ParseUnfolding ( parseUnfolding ) where
4
5 IMP_Ubiq(){-uitous-}
6
7 import HsSyn            -- quite a bit of stuff
8 import RdrHsSyn         -- oodles of synonyms
9 import HsDecls          ( HsIdInfo(..) )
10 import HsTypes          ( mkHsForAllTy )
11 import HsCore
12 import Literal
13 import PrimRep          ( decodePrimRep )
14 import HsPragmas        ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
15 import IdInfo           ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
16                           ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo
17                         )
18 import Kind             ( Kind, mkArrowKind, mkTypeKind )
19 import Lex              
20
21 import RnMonad          ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
22                           SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
23                         ) 
24 import Bag              ( emptyBag, unitBag, snocBag )
25 import FiniteMap        ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
26 import Name             ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
27 import SrcLoc           ( mkIfaceSrcLoc )
28 import Util             ( panic{-, pprPanic ToDo:rm-} )
29 import Pretty           ( Doc )
30 import Outputable       ( PprStyle(..) )
31 import Maybes           ( MaybeErr(..) )
32
33 ------------------------------------------------------------------
34
35 parseUnfolding ls =
36   let
37    res =
38     case parseUnfold ls of
39       v@(Succeeded _) -> v
40         -- ill-formed unfolding, crash and burn.
41       Failed err      -> panic (show (err PprDebug))
42   in
43   res
44 }
45
46 %name parseUnfold
47 %tokentype { IfaceToken }
48 %monad      { IfM }{ thenIf }{ returnIf }
49
50 %token
51         PRAGMAS_PART        { ITpragmas }
52         DATA                { ITdata }
53         TYPE                { ITtype }
54         NEWTYPE             { ITnewtype }
55         DERIVING            { ITderiving }
56         CLASS               { ITclass }
57         WHERE               { ITwhere }
58         INSTANCE            { ITinstance }
59         FORALL              { ITforall }
60         BANG                { ITbang }
61         VBAR                { ITvbar }
62         DCOLON              { ITdcolon }
63         COMMA               { ITcomma }
64         DARROW              { ITdarrow }
65         DOTDOT              { ITdotdot }
66         EQUAL               { ITequal }
67         OCURLY              { ITocurly }
68         OBRACK              { ITobrack }
69         OPAREN              { IToparen }
70         RARROW              { ITrarrow }
71         CCURLY              { ITccurly }
72         CBRACK              { ITcbrack }
73         CPAREN              { ITcparen }
74         SEMI                { ITsemi }
75
76         VARID               { ITvarid    $$ }
77         CONID               { ITconid    $$ }
78         VARSYM              { ITvarsym   $$ }
79         CONSYM              { ITconsym   $$ }
80         QVARID              { ITqvarid   $$ }
81         QCONID              { ITqconid   $$ }
82         QVARSYM             { ITqvarsym  $$ }
83         QCONSYM             { ITqconsym  $$ }
84
85         ARITY_PART      { ITarity }
86         STRICT_PART     { ITstrict }
87         UNFOLD_PART     { ITunfold $$ }
88         DEMAND          { ITdemand $$ }
89         BOTTOM          { ITbottom }
90         LAM             { ITlam }
91         BIGLAM          { ITbiglam }
92         CASE            { ITcase }
93         PRIM_CASE       { ITprim_case }
94         LET             { ITlet }
95         LETREC          { ITletrec }
96         IN              { ITin }
97         OF              { ITof }
98         COERCE_IN       { ITcoerce_in }
99         COERCE_OUT      { ITcoerce_out }
100         ATSIGN          { ITatsign }
101         CCALL           { ITccall $$ }
102         SCC             { ITscc $$ }
103
104         CHAR            { ITchar $$ }
105         STRING          { ITstring $$ } 
106         INTEGER         { ITinteger  $$ }
107         DOUBLE          { ITdouble $$ }
108
109         INTEGER_LIT     { ITinteger_lit }
110         FLOAT_LIT       { ITfloat_lit }
111         RATIONAL_LIT    { ITrational_lit }
112         ADDR_LIT        { ITaddr_lit }
113         LIT_LIT         { ITlit_lit }
114         STRING_LIT      { ITstring_lit }
115
116         UNKNOWN         { ITunknown $$ }
117 %%
118
119 id_info         :: { [HsIdInfo RdrName] }
120 id_info         :                                               { [] }
121                 | id_info_item id_info                          { $1 : $2 }
122
123 id_info_item    :: { HsIdInfo RdrName }
124 id_info_item    : ARITY_PART arity_info                 { HsArity $2 }
125                 | STRICT_PART strict_info               { HsStrictness $2 }
126                 | BOTTOM                                { HsStrictness mkBottomStrictnessInfo }
127                 | UNFOLD_PART core_expr                 { HsUnfold $1 $2 }
128
129 arity_info      :: { ArityInfo }
130 arity_info      : INTEGER                                       { exactArity (fromInteger $1) }
131
132 strict_info     :: { StrictnessInfo RdrName }
133 strict_info     : DEMAND any_var_name OCURLY data_names CCURLY  { mkStrictnessInfo $1 (Just ($2,$4)) }
134                 | DEMAND any_var_name                           { mkStrictnessInfo $1 (Just ($2,[])) }
135                 | DEMAND                                        { mkStrictnessInfo $1 Nothing }
136
137 core_expr       :: { UfExpr RdrName }
138 core_expr       : any_var_name                                  { UfVar $1 }
139                 | data_name                                     { UfVar $1 }
140                 | core_lit                                      { UfLit $1 }
141                 | OPAREN core_expr CPAREN                       { $2 }
142                 | data_name OCURLY data_args CCURLY             { UfCon $1 $3 }
143
144                 | core_expr ATSIGN atype                        { UfApp $1 (UfTyArg $3) }
145                 | core_expr core_arg                            { UfApp $1 $2 }
146                 | LAM core_val_bndrs RARROW core_expr           { foldr UfLam $4 $2 }
147                 | BIGLAM core_tv_bndrs RARROW core_expr         { foldr UfLam $4 $2 }
148
149                 | CASE core_expr OF 
150                   OCURLY alg_alts core_default CCURLY           { UfCase $2 (UfAlgAlts  $5 $6) }
151                 | PRIM_CASE core_expr OF 
152                   OCURLY prim_alts core_default CCURLY          { UfCase $2 (UfPrimAlts $5 $6) }
153
154
155                 | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
156                   IN core_expr                                  { UfLet (UfNonRec $3 $5) $8 }
157                 | LETREC OCURLY rec_binds CCURLY                
158                   IN core_expr                                  { UfLet (UfRec $3) $6 }
159
160                 | coerce atype core_expr                        { UfCoerce $1 $2 $3 }
161
162                 | CCALL ccall_string 
163                         OBRACK atype atypes CBRACK core_args    { let
164                                                                         (is_casm, may_gc) = $1
165                                                                   in
166                                                                   UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
167                                                                          $7
168                                                                 }
169                 | SCC core_expr                                 {  UfSCC $1 $2  }
170
171 rec_binds       :: { [(UfBinder RdrName, UfExpr RdrName)] }
172                 :                                               { [] }
173                 | core_val_bndr EQUAL core_expr SEMI rec_binds  { ($1,$3) : $5 }
174
175 coerce          :: { UfCoercion RdrName }
176 coerce          : COERCE_IN  data_name                          { UfIn  $2 }
177                 | COERCE_OUT data_name                          { UfOut $2 }
178                 
179 prim_alts       :: { [(Literal,UfExpr RdrName)] }
180                 :                                               { [] }
181                 | core_lit RARROW core_expr SEMI prim_alts      { ($1,$3) : $5 }
182
183 alg_alts        :: { [(RdrName, [RdrName], UfExpr RdrName)] }
184                 :                                               { [] }
185                 | data_name var_names RARROW 
186                         core_expr SEMI alg_alts                 { ($1,$2,$4) : $6 }
187
188 core_default    :: { UfDefault RdrName }
189                 :                                               { UfNoDefault }
190                 | var_name RARROW core_expr SEMI                { UfBindDefault $1 $3 }
191
192 core_arg        :: { UfArg RdrName }
193                 : any_var_name                                  { UfVarArg $1 }
194                 | data_name                                     { UfVarArg $1 }
195                 | core_lit                                      { UfLitArg $1 }
196
197 core_args       :: { [UfArg RdrName] }
198                 :                                               { [] }
199                 | core_arg core_args                            { $1 : $2 }
200
201 data_args       :: { [UfArg RdrName] }
202                 :                                               { [] }
203                 | ATSIGN atype data_args                        { UfTyArg $2 : $3 }
204                 | core_arg data_args                            { $1 : $2 }
205
206 core_lit        :: { Literal }
207 core_lit        : INTEGER                       { MachInt $1 True }
208                 | CHAR                          { MachChar $1 }
209                 | STRING                        { MachStr $1 }
210                 | STRING_LIT STRING             { NoRepStr $2 }
211                 | DOUBLE                        { MachDouble (toRational $1) }
212                 | FLOAT_LIT DOUBLE              { MachFloat (toRational $2) }
213
214                 | INTEGER_LIT INTEGER           { NoRepInteger  $2 (panic "NoRepInteger type") 
215                                                         -- The type checker will add the types
216                                                 }
217
218                 | RATIONAL_LIT INTEGER INTEGER  { NoRepRational ($2 % $3) 
219                                                                 (panic "NoRepRational type")
220                                                                         -- The type checker will add the type
221                                                 }
222
223                 | ADDR_LIT INTEGER              { MachAddr $2 }
224                 | LIT_LIT prim_rep STRING       { MachLitLit $3 (decodePrimRep $2) }
225
226 core_val_bndr   :: { UfBinder RdrName }
227 core_val_bndr   : var_name DCOLON atype                         { UfValBinder $1 $3 }
228
229 core_val_bndrs  :: { [UfBinder RdrName] }
230 core_val_bndrs  :                                               { [] }
231                 | core_val_bndr core_val_bndrs                  { $1 : $2 }
232
233 core_tv_bndr    :: { UfBinder RdrName }
234 core_tv_bndr    :  tv_name DCOLON akind                         { UfTyBinder $1 $3 }
235                 |  tv_name                                      { UfTyBinder $1 mkTypeKind }
236
237 core_tv_bndrs   :: { [UfBinder RdrName] }
238 core_tv_bndrs   :                                               { [] }
239                 | core_tv_bndr core_tv_bndrs                    { $1 : $2 }
240
241 ccall_string    :: { FAST_STRING }
242                 : STRING                                        { $1 }
243                 | VARID                                         { $1 }
244                 | CONID                                         { $1 }
245
246 prim_rep  :: { Char }
247           : VARID                                               { head (_UNPK_ $1) }
248           | CONID                                               { head (_UNPK_ $1)
249
250 ---variable names-----------------------------------------------------
251                                                                      }
252 var_occ         :: { OccName }
253 var_occ         : VARID                 { VarOcc $1 }
254                 | VARSYM                { VarOcc $1 }
255                 | BANG                  { VarOcc SLIT("!") {-sigh, double-sigh-} }
256
257 data_name       :: { RdrName }
258 data_name       :  QCONID               { varQual $1 }
259                 |  QCONSYM              { varQual $1 }
260                 |  CONID                { Unqual (VarOcc $1) }
261                 |  CONSYM               { Unqual (VarOcc $1) }
262
263 qvar_name       :: { RdrName }
264                 :  QVARID               { varQual $1 }
265                 |  QVARSYM              { varQual $1 }
266
267 var_name        :: { RdrName }
268 var_name        :  var_occ              { Unqual $1 }
269
270 any_var_name    :: {RdrName}
271 any_var_name    :  var_name             { $1 }
272                 |  qvar_name            { $1 }
273
274 var_names       :: { [RdrName] }
275 var_names       :                       { [] }
276                 | var_name var_names    { $1 : $2 }
277
278 data_names      :: { [RdrName] }
279 data_names      :                       { [] }
280                 | data_name data_names  { $1 : $2
281
282 --productions-for-types--------------------------------
283                                              }
284 forall          : OBRACK tv_bndrs CBRACK                { $2 }
285
286 context         :: { RdrNameContext }
287 context         :                                       { [] }
288                 | OCURLY context_list1 CCURLY           { $2 }
289
290 context_list1   :: { RdrNameContext }
291 context_list1   : class                                 { [$1] }
292                 | class COMMA context_list1             { $1 : $3 }
293
294 class           :: { (RdrName, RdrNameHsType) }
295 class           :  tc_name atype                        { ($1, $2) }
296
297 type            :: { RdrNameHsType }
298 type            : FORALL forall context DARROW type     { mkHsForAllTy $2 $3 $5 }
299                 |  btype RARROW type                    { MonoFunTy $1 $3 }
300                 |  btype                                { $1 }
301
302 types2          :: { [RdrNameHsType]                    {- Two or more -}  }    
303 types2          :  type COMMA type                      { [$1,$3] }
304                 |  type COMMA types2                    { $1 : $3 }
305
306 btype           :: { RdrNameHsType }
307 btype           :  atype                                { $1 }
308                 |  btype atype                          { MonoTyApp $1 $2 }
309
310 atype           :: { RdrNameHsType }
311 atype           :  tc_name                              { MonoTyVar $1 }
312                 |  tv_name                              { MonoTyVar $1 }
313                 |  OPAREN types2 CPAREN                 { MonoTupleTy dummyRdrTcName $2 }
314                 |  OBRACK type CBRACK                   { MonoListTy  dummyRdrTcName $2 }
315                 |  OCURLY tc_name atype CCURLY          { MonoDictTy $2 $3 }
316                 |  OPAREN type CPAREN                   { $2 }
317
318 atypes          :: { [RdrNameHsType]    {-  Zero or more -} }
319 atypes          :                                       { [] }
320                 |  atype atypes                         { $1 : $2
321 ---------------------------------------------------------------------
322                                                         }
323
324 tv_bndr         :: { HsTyVar RdrName }
325 tv_bndr         :  tv_name DCOLON akind { IfaceTyVar $1 $3 }
326                 |  tv_name              { UserTyVar $1 }
327
328 tv_bndrs        :: { [HsTyVar RdrName] }
329                 :                       { [] }
330                 | tv_bndr tv_bndrs      { $1 : $2 }
331
332 kind            :: { Kind }
333                 : akind                 { $1 }
334                 | akind RARROW kind     { mkArrowKind $1 $3 }
335
336 akind           :: { Kind }
337                 : VARSYM                { mkTypeKind {- ToDo: check that it's "*" -} }
338                 | OPAREN kind CPAREN    { $2 }
339
340 tv_name         :: { RdrName }
341 tv_name         :  VARID                { Unqual (TvOcc $1) }
342
343 tv_names        :: { [RdrName] }
344                 :                       { [] }
345                 | tv_name tv_names      { $1 : $2 }
346
347 tc_name         :: { RdrName }
348 tc_name         :  QCONID               { tcQual $1 }
349                 |  CONID                { Unqual (TCOcc $1) }
350                 |  CONSYM               { Unqual (TCOcc $1) }
351                 |  OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }