2 #include "HsVersions.h"
3 module ParseUnfolding ( parseUnfolding ) where
7 import HsSyn -- quite a bit of stuff
8 import RdrHsSyn -- oodles of synonyms
9 import HsDecls ( HsIdInfo(..) )
10 import HsTypes ( mkHsForAllTy )
13 import PrimRep ( decodePrimRep )
14 import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
15 import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
16 ArgUsageInfo, FBTypeInfo
18 import Kind ( Kind, mkArrowKind, mkTypeKind )
21 import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
22 SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
24 import Bag ( emptyBag, unitBag, snocBag )
25 import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
26 import Name ( OccName(..), isTCOcc, Provenance )
27 import SrcLoc ( mkIfaceSrcLoc )
28 import Util ( panic{-, pprPanic ToDo:rm-} )
29 import Pretty ( ppShow )
30 import PprStyle -- PprDebug for panic
31 import Maybes ( MaybeErr(..) )
33 ------------------------------------------------------------------
38 case parseUnfold ls of
40 -- ill-formed unfolding, crash and burn.
41 Failed err -> panic (ppShow 80 (err PprDebug))
47 %tokentype { IfaceToken }
48 %monad { IfM }{ thenIf }{ returnIf }
51 PRAGMAS_PART { ITpragmas }
55 DERIVING { ITderiving }
58 INSTANCE { ITinstance }
78 VARSYM { ITvarsym $$ }
79 CONSYM { ITconsym $$ }
80 QVARID { ITqvarid $$ }
81 QCONID { ITqconid $$ }
82 QVARSYM { ITqvarsym $$ }
83 QCONSYM { ITqconsym $$ }
85 ARITY_PART { ITarity }
86 STRICT_PART { ITstrict }
87 UNFOLD_PART { ITunfold }
88 DEMAND { ITdemand $$ }
93 PRIM_CASE { ITprim_case }
98 COERCE_IN { ITcoerce_in }
99 COERCE_OUT { ITcoerce_out }
105 STRING { ITstring $$ }
106 INTEGER { ITinteger $$ }
107 DOUBLE { ITdouble $$ }
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 }
116 UNKNOWN { ITunknown $$ }
119 id_info :: { [HsIdInfo RdrName] }
121 | id_info_item id_info { $1 : $2 }
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 $2 }
129 arity_info :: { ArityInfo }
130 arity_info : INTEGER { exactArity (fromInteger $1) }
132 strict_info :: { StrictnessInfo RdrName }
133 strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) }
134 | DEMAND { mkStrictnessInfo $1 Nothing }
136 core_expr :: { UfExpr RdrName }
137 core_expr : any_var_name { UfVar $1 }
138 | qdata_name { UfVar $1 }
139 | core_lit { UfLit $1 }
140 | OPAREN core_expr CPAREN { $2 }
141 | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 }
143 | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
144 | core_expr core_arg { UfApp $1 $2 }
145 | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 }
146 | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
149 OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
150 | PRIM_CASE core_expr OF
151 OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) }
154 | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
155 IN core_expr { UfLet (UfNonRec $3 $5) $8 }
156 | LETREC OCURLY rec_binds CCURLY
157 IN core_expr { UfLet (UfRec $3) $6 }
159 | coerce atype core_expr { UfCoerce $1 $2 $3 }
162 OBRACK atype atypes CBRACK core_args { let
163 (is_casm, may_gc) = $1
165 UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
168 | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 }
170 rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
172 | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
174 coerce :: { UfCoercion RdrName }
175 coerce : COERCE_IN qdata_name { UfIn $2 }
176 | COERCE_OUT qdata_name { UfOut $2 }
178 prim_alts :: { [(Literal,UfExpr RdrName)] }
180 | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
182 alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
184 | qdata_name var_names RARROW
185 core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
187 core_default :: { UfDefault RdrName }
189 | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
191 core_arg :: { UfArg RdrName }
192 : var_name { UfVarArg $1 }
193 | qvar_name { UfVarArg $1 }
194 | qdata_name { UfVarArg $1 }
195 | core_lit { UfLitArg $1 }
197 core_args :: { [UfArg RdrName] }
199 | core_arg core_args { $1 : $2 }
201 data_args :: { [UfArg RdrName] }
203 | ATSIGN atype data_args { UfTyArg $2 : $3 }
204 | core_arg data_args { $1 : $2 }
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) }
214 | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
215 -- The type checker will add the types
218 | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3)
219 (panic "NoRepRational type")
220 -- The type checker will add the type
223 | ADDR_LIT INTEGER { MachAddr $2 }
224 | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) }
226 core_val_bndr :: { UfBinder RdrName }
227 core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
229 core_val_bndrs :: { [UfBinder RdrName] }
230 core_val_bndrs : { [] }
231 | core_val_bndr core_val_bndrs { $1 : $2 }
233 core_tv_bndr :: { UfBinder RdrName }
234 core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 }
235 | tv_name { UfTyBinder $1 mkTypeKind }
237 core_tv_bndrs :: { [UfBinder RdrName] }
238 core_tv_bndrs : { [] }
239 | core_tv_bndr core_tv_bndrs { $1 : $2 }
241 ccall_string :: { FAST_STRING }
247 : VARID { head (_UNPK_ $1) }
248 | CONID { head (_UNPK_ $1)
250 ---variable names-----------------------------------------------------
252 var_occ :: { OccName }
253 var_occ : VARID { VarOcc $1 }
254 | VARSYM { VarOcc $1 }
255 | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
257 qdata_name :: { RdrName }
258 qdata_name : QCONID { varQual $1 }
259 | QCONSYM { varQual $1 }
261 qvar_name :: { RdrName }
262 : QVARID { varQual $1 }
263 | QVARSYM { varQual $1 }
265 var_name :: { RdrName }
266 var_name : var_occ { Unqual $1 }
268 any_var_name :: {RdrName}
269 any_var_name : var_name { $1 }
272 var_names :: { [RdrName] }
274 | var_name var_names { $1 : $2
276 --productions-for-types--------------------------------
278 forall : OBRACK tv_bndrs CBRACK { $2 }
280 context :: { RdrNameContext }
282 | OCURLY context_list1 CCURLY { $2 }
284 context_list1 :: { RdrNameContext }
285 context_list1 : class { [$1] }
286 | class COMMA context_list1 { $1 : $3 }
288 class :: { (RdrName, RdrNameHsType) }
289 class : qtc_name atype { ($1, $2) }
291 type :: { RdrNameHsType }
292 type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
295 tautype :: { RdrNameHsType }
296 tautype : btype { $1 }
297 | btype RARROW tautype { MonoFunTy $1 $3 }
299 types2 :: { [RdrNameHsType] {- Two or more -} }
300 types2 : type COMMA type { [$1,$3] }
301 | type COMMA types2 { $1 : $3 }
303 btype :: { RdrNameHsType }
305 | btype atype { MonoTyApp $1 $2 }
307 atype :: { RdrNameHsType }
308 atype : qtc_name { MonoTyVar $1 }
309 | tv_name { MonoTyVar $1 }
310 | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
311 | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
312 | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
313 | OPAREN type CPAREN { $2 }
315 atypes :: { [RdrNameHsType] {- Zero or more -} }
317 | atype atypes { $1 : $2
318 ---------------------------------------------------------------------
321 tv_bndr :: { HsTyVar RdrName }
322 tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
323 | tv_name { UserTyVar $1 }
325 tv_bndrs :: { [HsTyVar RdrName] }
327 | tv_bndr tv_bndrs { $1 : $2 }
331 | akind RARROW kind { mkArrowKind $1 $3 }
334 : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} }
335 | OPAREN kind CPAREN { $2 }
337 tv_name :: { RdrName }
338 tv_name : VARID { Unqual (TvOcc $1) }
340 tv_names :: { [RdrName] }
342 | tv_name tv_names { $1 : $2 }
343 qtc_name :: { RdrName }
344 qtc_name : QCONID { tcQual $1 }