2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
7 #include "HsVersions.h"
16 import TcMonad hiding ( rnMtoTcM )
17 import HsSyn -- the stuff being typechecked
19 --import PrelInfo ( PrimOp(..) -- to see CCallOp
24 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
25 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
28 --import WwLib ( mkWwBodies )
29 import Maybes ( assocMaybe, catMaybes )
30 --import CoreLint ( lintUnfolding )
31 import TcMonoType ( tcMonoType, tcPolyType )
36 The basic idea is: Given an @Id@ that only lacks its @IdInfo@
37 (represented as a function \tr{IdInfo -> Id}, use the pragmas given to
38 figure out the @IdInfo@, then give back the now-complete @Id@.
40 Of course, the pragmas also need to be checked.
42 %************************************************************************
44 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
46 %************************************************************************
49 tcClassOpPragmas :: E -- Class/TyCon lookup tables
50 -> Type -- global type of the class method
51 -> Id -- *final* ClassOpId
52 -> Id -- *final* DefaultMethodId
53 -> SpecEnv -- Instance info for this class op
54 -> RenamedClassOpPragmas -- info w/ which to complete, giving...
55 -> Baby_TcM (IdInfo, IdInfo) -- ... final info for ClassOp and DefaultMethod
57 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
58 = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
60 tcClassOpPragmas e global_ty
61 rec_classop_id rec_defm_id
63 (ClassOpPragmas classop_pragmas defm_pragmas)
65 Nothing{-ty unknown-} rec_classop_id
66 classop_pragmas `thenB_Tc` \ classop_idinfo ->
69 Nothing{-ty unknown-} rec_defm_id
70 defm_pragmas `thenB_Tc` \ defm_idinfo ->
72 returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
75 %************************************************************************
77 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
79 %************************************************************************
81 {\em Every} instance declaration produces a ``dictionary function''
82 (dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
83 convey information about a DictFunId.
87 :: E -- Class/TyCon lookup tables
88 -> Type -- DictFunId type
89 -> Id -- final DictFunId (don't touch)
90 -> RenamedInstancePragmas -- info w/ which to complete, giving...
91 -> Baby_TcM IdInfo -- ... final DictFun IdInfo
93 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
96 tcDictFunPragmas e dfun_ty final_dfun pragmas
100 SimpleInstancePragma x -> x
101 ConstantInstancePragma x _ -> x
102 SpecialisedInstancePragma x _ -> x
104 tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
107 %************************************************************************
109 \subsection[tcGenPragmas]{Basic pragmas about a value}
111 %************************************************************************
113 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
114 a problem, it just returns @noIdInfo@.
119 -> Maybe Type -- of Id, if we have it (for convenience)
120 -> Id -- *incomplete* Id (do not *touch*!)
121 -> RenamedGenPragmas -- info w/ which to complete, giving...
122 -> Baby_TcM IdInfo -- IdInfo for this Id
124 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
125 = returnB_Tc noIdInfo
127 tcGenPragmas e ty_maybe rec_final_id
128 (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
129 = -- Guarantee success!
130 recoverIgnoreErrorsB_Tc noIdInfo (
132 -- OK, now we do the business
134 arity_info = get_arity arity_maybe
135 upd_info = get_upd upd_maybe
137 tc_strictness e ty_maybe rec_final_id strictness
138 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
140 -- If the unfolding fails to look consistent, we don't
141 -- want to junk *all* the IdInfo
142 recoverIgnoreErrorsB_Tc noInfo_UF (
143 tc_unfolding e unfold
144 ) `thenB_Tc` \ unfold_info ->
146 -- Same as unfolding; if we fail, don't junk all IdInfo
147 recoverIgnoreErrorsB_Tc nullSpecEnv (
148 tc_specs e rec_final_id ty_maybe specs
149 ) `thenB_Tc` \ spec_env ->
157 -- The strictness info *may* imply an unfolding
158 -- (the "wrapper_unfold"); that info is added; if
159 -- there is also an explicit unfolding, it will
160 -- take precedence, because it is "added" later.
161 `addInfo` strict_info
162 `addInfo_UF` wrapper_unfold_info
164 `addInfo_UF` unfold_info
168 get_arity Nothing = noInfo
169 get_arity (Just a) = mkArityInfo a
171 get_upd Nothing = noInfo
172 get_upd (Just u) = (u :: UpdateInfo)
175 Don't use the strictness info if a flag set.
180 -> Id -- final Id (do not *touch*)
181 -> ImpStrictness Name
182 -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
184 tc_strictness e ty_maybe rec_final_id info
185 = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
186 if sw_chkr IgnoreStrictnessPragmas then
187 returnB_Tc (noInfo, noInfo_UF)
189 do_strictness e ty_maybe rec_final_id info
194 do_strictness e ty_maybe rec_final_id NoImpStrictness
195 = returnB_Tc (noInfo, noInfo_UF)
198 We come to a nasty one now. We have strictness info---possibly
199 implying a worker---but (for whatever reason) no {\em type}
200 information for the wrapper. We therefore want (a)~{\em not} to
201 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
202 never asked for (!); and (b)~we want to keep the strictness/absence
203 info, because there's too much good stuff there to ignore completely.
204 We are not bothered about any pragmatic info for any alleged worker.
205 NB: this code applies only to {\em imported} info. So here we go:
208 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
212 then mkBottomStrictnessInfo
213 else mkStrictnessInfo arg_info Nothing
215 returnB_Tc (strictness_info, noInfo_UF)
216 -- no unfolding: the key --^^^^^^
219 And, finally, the have-everthing, know-everything, do-everything
222 do_strictness e (Just wrapper_ty) rec_final_id
223 (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
225 | is_bot -- it's a "bottoming Id"
226 = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
228 | not (indicatesWorker wrap_arg_info)
230 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
233 = -- Strictness info suggests a worker. Things could still
234 -- go wrong if there's an abstract type involved, mind you.
236 (tv_tmpls, arg_tys, ret_ty) = splitFunTyExpandingDicts wrapper_ty
237 n_wrapper_args = length wrap_arg_info
238 -- Don't have more args than this, else you risk
241 getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
242 getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
245 (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
247 inst_arg_tys = map (instantiateTy inst_env) arg_tys
248 (undropped_inst_arg_tys, dropped_inst_arg_tys)
249 = splitAt n_wrapper_args inst_arg_tys
251 inst_ret_ty = glueTyArgs dropped_inst_arg_tys
252 (instantiateTy inst_env ret_ty)
254 args = zipWithEqual "do_strictness" mk_arg arg_uniqs undropped_inst_arg_tys
255 mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
256 -- ASSERT: length args = n_wrapper_args
259 uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
260 `thenB_Tc` \ result ->
263 Nothing -> -- Alas, we met an abstract type
264 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
266 Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
269 worker_ty = worker_ty_w_hole inst_ret_ty
271 getUniqueB_Tc `thenB_Tc` \ uniq ->
272 fixB_Tc ( \ rec_wrkr_id ->
277 wrkr_pragmas `thenB_Tc` \ wrkr_id_info ->
279 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
280 (wrkr_id_info `addInfo` worker_strictness))
281 -- Note: the above will *clobber* any strictness
282 -- info for the worker which was read in from the
283 -- interface (but there usually isn't any).
285 ) `thenB_Tc` \ worker_id ->
288 wrapper_rhs = wrapper_w_hole worker_id
289 n_tyvars = length tyvars
294 mkStrictnessInfo wrap_arg_info (Just worker_id),
295 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
296 -- We only do this for imported things, which this is.
302 -> Id -- final Id for which these are specialisations (do not *touch*)
304 -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
307 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
308 = returnB_Tc nullSpecEnv -- ToDo: msg????????
310 tc_specs e rec_main_id (Just main_ty) spec_pragmas
311 = mapB_Tc do_one_pragma spec_pragmas `thenB_Tc` \ spec_infos ->
312 returnB_Tc (mkSpecEnv spec_infos)
314 (main_tyvars, _) = splitForalls main_ty
319 do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
320 = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
321 `thenB_Tc` \ maybe_tys ->
322 getSrcLocB_Tc `thenB_Tc` \ locn ->
323 getUniqueB_Tc `thenB_Tc` \ uniq ->
325 checkB_Tc (length main_tyvars /= length maybe_tys)
326 (badSpecialisationErr "value" "wrong number of specialising types"
327 (length main_tyvars) maybe_tys locn)
330 spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
332 fixB_Tc ( \ rec_spec_id ->
334 tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
335 `thenB_Tc` \ spec_id_info ->
337 returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
339 ) `thenB_Tc` \ spec_id ->
341 returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
343 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
344 tc_ty_maybe rec_ce rec_tce (Just ty)
345 = tcMonoType rec_ce rec_tce nullTVE ty `thenB_Tc` \ new_ty ->
346 returnB_Tc (Just new_ty)
350 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
351 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
353 tc_unfolding e (ImpUnfolding guidance uf_core)
354 = tc_uf_core nullLVE nullTVE uf_core `thenB_Tc` \ core_expr ->
355 getSrcLocB_Tc `thenB_Tc` \ locn ->
357 -- Bad unfoldings are so painful that we always lint-check them,
358 -- marking them with BadUnfolding if lintUnfolding fails
359 -- NB: We cant check the lint result and return noInfo_UF if
360 -- lintUnfolding failed as this is too strict
361 -- Instead getInfo_UF tests for BadUnfolding and converts
362 -- to NoUnfoldingDetails when the unfolding is accessed
364 maybe_lint_expr = lintUnfolding locn core_expr
366 (lint_guidance, lint_expr) = case maybe_lint_expr of
367 Just lint_expr -> (guidance, lint_expr)
368 Nothing -> (BadUnfolding, panic_expr)
370 returnB_Tc (mkUnfolding lint_guidance lint_expr)
375 panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
377 tc_uf_core :: LVE -- lookup table for local binders
378 -- (others: we hope we can figure them out)
379 -> TVE -- lookup table for tyvars
380 -> UnfoldingCoreExpr Name
383 tc_uf_core lve tve (UfVar v)
384 = tc_uf_Id lve v `thenB_Tc` \ id ->
387 tc_uf_core lve tve (UfLit l)
390 tc_uf_core lve tve (UfCon con tys as)
391 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
392 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
393 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
394 returnB_Tc (Con con_id core_tys core_atoms)
396 -- If a ccall, we have to patch in the types read from the pragma.
398 tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
399 = ASSERT(null app_tys)
400 mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
401 tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
402 mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
403 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
404 returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
405 core_app_tys core_atoms)
407 tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
408 = mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
409 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
410 returnB_Tc (Prim op core_tys core_atoms)
412 tc_uf_core lve tve (UfLam binder body)
413 = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
415 [new_binder] = map snd lve2
416 new_lve = lve2 `plusLVE` lve
418 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
419 returnB_Tc (Lam new_binder new_body)
421 tc_uf_core lve tve (UfApp fun arg)
422 = tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
423 tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
424 returnB_Tc (App new_fun new_arg)
426 tc_uf_core lve tve (UfCase scrut alts)
427 = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
428 tc_alts alts `thenB_Tc` \ new_alts ->
429 returnB_Tc (Case new_scrut new_alts)
431 tc_alts (UfCoAlgAlts alts deflt)
432 = mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
433 tc_deflt deflt `thenB_Tc` \ new_deflt ->
434 returnB_Tc (AlgAlts new_alts new_deflt)
436 tc_alg_alt (con, params, rhs)
437 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
438 tc_uf_binders tve params `thenB_Tc` \ lve2 ->
440 new_params = map snd lve2
441 new_lve = lve2 `plusLVE` lve
443 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
444 returnB_Tc (con_id, new_params, new_rhs)
446 tc_alts (UfCoPrimAlts alts deflt)
447 = mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
448 tc_deflt deflt `thenB_Tc` \ new_deflt ->
449 returnB_Tc (PrimAlts new_alts new_deflt)
451 tc_prim_alt (lit, rhs)
452 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
453 returnB_Tc (lit, new_rhs)
455 tc_deflt UfCoNoDefault = returnB_Tc NoDefault
456 tc_deflt (UfCoBindDefault b rhs)
457 = tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
459 [new_b] = map snd lve2
460 new_lve = lve2 `plusLVE` lve
462 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
463 returnB_Tc (BindDefault new_b new_rhs)
465 tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
466 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
467 tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
469 [new_b] = map snd lve2
470 new_lve = lve2 `plusLVE` lve
472 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
473 returnB_Tc (Let (NonRec new_b new_rhs) new_body)
475 tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
477 (binders, rhss) = unzip pairs
479 tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
481 new_binders = map snd lve2
482 new_lve = lve2 `plusLVE` lve
484 mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
485 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
486 returnB_Tc (Let (Rec (zipEqual "tc_uf_core" new_binders new_rhss)) new_body)
488 tc_uf_core lve tve (UfSCC uf_cc body)
489 = tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
490 tc_uf_core lve tve body `thenB_Tc` \ new_body ->
491 returnB_Tc (SCC new_cc new_body)
493 tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
494 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
495 returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
497 tc_uf_cc (UfDictCC id m g is_dupd is_caf)
498 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
499 returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
501 tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
503 tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
504 tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
507 adjust is_caf is_dupd cc
509 maybe_cafify = if is_caf then cafifyCC else (\x->x)
510 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
512 maybe_dupify (maybe_cafify cc)
515 tc_uf_atom lve tve (UfCoLitAtom l)
516 = returnB_Tc (LitArg l)
518 tc_uf_atom lve tve (UfCoVarAtom v)
519 = tc_uf_Id lve v `thenB_Tc` \ new_v ->
520 returnB_Tc (VarArg new_v)
523 tc_uf_binders tve ids_and_tys
525 (ids, tys) = unzip ids_and_tys
527 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ new_tys ->
529 returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
532 -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
534 tc_uf_tyvar (Short u short_name)
536 tyvar = mkUserTyVar u short_name
538 (tyvar, u, mkTyVarTy tyvar)
541 tc_uf_Id lve (BoringUfId v)
542 = case (assocMaybe lve v) of
543 Just xx -> returnB_Tc xx
544 Nothing -> case (lookupE_ValueQuietly e v) of
545 Just xx -> returnB_Tc xx
546 Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
547 -- (ppCat [ppStr "Failed lookup for BoringUfId:",
549 (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
550 -- will be recover'd from
551 -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
553 tc_uf_Id lve (SuperDictSelUfId c sc)
555 clas = lookupCE rec_ce c
556 super_clas = lookupCE rec_ce sc
558 returnB_Tc (classSuperDictSelId clas super_clas)
560 tc_uf_Id lve (ClassOpUfId c op_name)
562 clas = lookupCE rec_ce c
563 op = lookup_class_op clas op_name
565 returnB_Tc (classOpId clas op)
567 tc_uf_Id lve (DefaultMethodUfId c op_name)
569 clas = lookupCE rec_ce c
570 op = lookup_class_op clas op_name
572 returnB_Tc (classDefaultMethodId clas op)
574 tc_uf_Id lve uf_id@(DictFunUfId c ty)
575 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
577 clas = lookupCE rec_ce c
578 dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
580 Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
581 (ppr PprDebug (UfVar uf_id))
582 -- The class and type are both
583 -- visible, so the instance should
584 -- jolly well be too!
588 tc_uf_Id lve (ConstMethodUfId c op_name ty)
589 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
591 clas = lookupCE rec_ce c
592 op = lookup_class_op clas op_name
594 returnB_Tc (getConstMethodId clas op new_ty)
596 tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
597 = tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
598 mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
599 `thenB_Tc` \ maybe_tys ->
601 spec_id = lookupSpecId unspec_id maybe_tys
605 tc_uf_Id lve (WorkerUfId unwrkr)
606 = tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
608 strictness_info = getIdStrictness unwrkr_id
610 if isLocallyDefined unwrkr_id
612 -- A locally defined value will not have any strictness info (yet),
613 -- so we can't extract the locally defined worker Id from it :-(
615 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
616 (ppCat [ppStr "Worker Id in unfolding is defined locally:",
617 ppr PprDebug unwrkr_id])
618 (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
619 -- will be recover'd from
621 returnB_Tc (getWorkerId strictness_info)
624 lookup_class_op clas (ClassOpName _ _ _ tag)
625 = classOps clas !! (tag - 1)
627 ---------------------------------------------------------------------
628 tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
630 tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
633 %************************************************************************
635 \subsection[tcDataPragmas]{@data@ type pragmas}
637 %************************************************************************
639 The purpose of a @data@ pragma is to convey data-constructor
640 information that would otherwise be unknown.
642 It also records specialisation information which is added to each data
643 constructor. This info just contains the type info for the
644 specialisations which exist. No specialised Ids are actually created.
647 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
648 -> RenamedDataPragmas
649 -> Baby_TcM ([RenamedConDecl], -- any pragma condecls
650 [SpecInfo]) -- specialisation info from pragmas
652 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
653 = mapB_Tc do_one_spec specs `thenB_Tc` \ spec_infos ->
654 returnB_Tc (con_decls, spec_infos)
656 do_one_spec maybe_monotys
657 = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
658 `thenB_Tc` \ maybe_tys ->
659 getSrcLocB_Tc `thenB_Tc` \ locn ->
661 checkB_Tc (length new_tyvars /= length maybe_tys)
662 (badSpecialisationErr "data" "wrong number of specialising types"
663 (length new_tyvars) maybe_tys locn)
666 checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
667 (badSpecialisationErr "data" "not all unboxed types"
668 (length new_tyvars) maybe_tys locn)
671 returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))