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(..), HsStrictnessInfo(..) )
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, ArityInfo, StrictnessInfo
18 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
21 import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
22 SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
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-} )
30 import Outputable ( PprStyle(..) )
31 import Maybes ( MaybeErr(..) )
33 ------------------------------------------------------------------
38 case parseUnfold ls of
40 -- ill-formed unfolding, crash and burn.
41 Failed err -> panic (show (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 HsBottom }
127 | UNFOLD_PART core_expr { HsUnfold $1 $2 }
129 arity_info :: { ArityInfo }
130 arity_info : INTEGER { exactArity (fromInteger $1) }
132 strict_info :: { HsStrictnessInfo RdrName }
133 strict_info : DEMAND any_var_name OCURLY data_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) }
134 | DEMAND any_var_name { HsStrictnessInfo $1 (Just ($2,[])) }
135 | DEMAND { HsStrictnessInfo $1 Nothing }
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 }
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 }
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) }
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 }
160 | coerce atype core_expr { UfCoerce $1 $2 $3 }
163 OBRACK atype atypes CBRACK core_args { let
164 (is_casm, may_gc) = $1
166 UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
169 | SCC core_expr { UfSCC $1 $2 }
171 rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
173 | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
175 coerce :: { UfCoercion RdrName }
176 coerce : COERCE_IN data_name { UfIn $2 }
177 | COERCE_OUT data_name { UfOut $2 }
179 prim_alts :: { [(Literal,UfExpr RdrName)] }
181 | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
183 alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
185 | data_name var_names RARROW
186 core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
188 core_default :: { UfDefault RdrName }
190 | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
192 core_arg :: { UfArg RdrName }
193 : any_var_name { UfVarArg $1 }
194 | data_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 mkBoxedTypeKind }
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 data_name :: { RdrName }
258 data_name : QCONID { lexVarQual $1 }
259 | QCONSYM { lexVarQual $1 }
260 | CONID { Unqual (VarOcc $1) }
261 | CONSYM { Unqual (VarOcc $1) }
263 qvar_name :: { RdrName }
264 : QVARID { lexVarQual $1 }
265 | QVARSYM { lexVarQual $1 }
267 var_name :: { RdrName }
268 var_name : var_occ { Unqual $1 }
270 any_var_name :: {RdrName}
271 any_var_name : var_name { $1 }
274 var_names :: { [RdrName] }
276 | var_name var_names { $1 : $2 }
278 data_names :: { [RdrName] }
280 | data_name data_names { $1 : $2
282 --productions-for-types--------------------------------
284 forall : OBRACK tv_bndrs CBRACK { $2 }
286 context :: { RdrNameContext }
288 | OCURLY context_list1 CCURLY { $2 }
290 context_list1 :: { RdrNameContext }
291 context_list1 : class { [$1] }
292 | class COMMA context_list1 { $1 : $3 }
294 class :: { (RdrName, RdrNameHsType) }
295 class : tc_name atype { ($1, $2) }
297 type :: { RdrNameHsType }
298 type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
299 | btype RARROW type { MonoFunTy $1 $3 }
302 types2 :: { [RdrNameHsType] {- Two or more -} }
303 types2 : type COMMA type { [$1,$3] }
304 | type COMMA types2 { $1 : $3 }
306 btype :: { RdrNameHsType }
308 | btype atype { MonoTyApp $1 $2 }
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 }
318 atypes :: { [RdrNameHsType] {- Zero or more -} }
320 | atype atypes { $1 : $2
321 ---------------------------------------------------------------------
324 tv_bndr :: { HsTyVar RdrName }
325 tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
326 | tv_name { UserTyVar $1 }
328 tv_bndrs :: { [HsTyVar RdrName] }
330 | tv_bndr tv_bndrs { $1 : $2 }
334 | akind RARROW kind { mkArrowKind $1 $3 }
337 : VARSYM { mkBoxedTypeKind {- ToDo: check that it's "*" -} }
338 | OPAREN kind CPAREN { $2 }
340 tv_name :: { RdrName }
341 tv_name : VARID { Unqual (TvOcc $1) }
342 | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
344 tv_names :: { [RdrName] }
346 | tv_name tv_names { $1 : $2 }
348 tc_name :: { RdrName }
349 tc_name : QCONID { lexTcQual $1 }
350 | CONID { Unqual (TCOcc $1) }
351 | CONSYM { Unqual (TCOcc $1) }
352 | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }