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 -- typechecking monadic machinery
17 import HsSyn -- the stuff being typechecked
19 import PrelInfo ( PrimOp(..) -- to see CCallOp
20 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
21 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
26 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
27 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
30 --import WwLib ( mkWwBodies )
31 import Maybes ( assocMaybe, catMaybes, Maybe(..) )
32 --import CoreLint ( lintUnfolding )
33 import TcMonoType ( tcMonoType, tcPolyType )
38 The basic idea is: Given an @Id@ that only lacks its @IdInfo@
39 (represented as a function \tr{IdInfo -> Id}, use the pragmas given to
40 figure out the @IdInfo@, then give back the now-complete @Id@.
42 Of course, the pragmas also need to be checked.
44 %************************************************************************
46 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
48 %************************************************************************
51 tcClassOpPragmas :: E -- Class/TyCon lookup tables
52 -> Type -- global type of the class method
53 -> Id -- *final* ClassOpId
54 -> Id -- *final* DefaultMethodId
55 -> SpecEnv -- Instance info for this class op
56 -> RenamedClassOpPragmas -- info w/ which to complete, giving...
57 -> Baby_TcM (IdInfo, IdInfo) -- ... final info for ClassOp and DefaultMethod
59 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
60 = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
62 tcClassOpPragmas e global_ty
63 rec_classop_id rec_defm_id
65 (ClassOpPragmas classop_pragmas defm_pragmas)
67 Nothing{-ty unknown-} rec_classop_id
68 classop_pragmas `thenB_Tc` \ classop_idinfo ->
71 Nothing{-ty unknown-} rec_defm_id
72 defm_pragmas `thenB_Tc` \ defm_idinfo ->
74 returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
77 %************************************************************************
79 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
81 %************************************************************************
83 {\em Every} instance declaration produces a ``dictionary function''
84 (dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
85 convey information about a DictFunId.
89 :: E -- Class/TyCon lookup tables
90 -> Type -- DictFunId type
91 -> Id -- final DictFunId (don't touch)
92 -> RenamedInstancePragmas -- info w/ which to complete, giving...
93 -> Baby_TcM IdInfo -- ... final DictFun IdInfo
95 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
98 tcDictFunPragmas e dfun_ty final_dfun pragmas
102 SimpleInstancePragma x -> x
103 ConstantInstancePragma x _ -> x
104 SpecialisedInstancePragma x _ -> x
106 tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
109 %************************************************************************
111 \subsection[tcGenPragmas]{Basic pragmas about a value}
113 %************************************************************************
115 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
116 a problem, it just returns @noIdInfo@.
121 -> Maybe Type -- of Id, if we have it (for convenience)
122 -> Id -- *incomplete* Id (do not *touch*!)
123 -> RenamedGenPragmas -- info w/ which to complete, giving...
124 -> Baby_TcM IdInfo -- IdInfo for this Id
126 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
127 = returnB_Tc noIdInfo
129 tcGenPragmas e ty_maybe rec_final_id
130 (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
131 = -- Guarantee success!
132 recoverIgnoreErrorsB_Tc noIdInfo (
134 -- OK, now we do the business
136 arity_info = get_arity arity_maybe
137 upd_info = get_upd upd_maybe
139 tc_strictness e ty_maybe rec_final_id strictness
140 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
142 -- If the unfolding fails to look consistent, we don't
143 -- want to junk *all* the IdInfo
144 recoverIgnoreErrorsB_Tc noInfo_UF (
145 tc_unfolding e unfold
146 ) `thenB_Tc` \ unfold_info ->
148 -- Same as unfolding; if we fail, don't junk all IdInfo
149 recoverIgnoreErrorsB_Tc nullSpecEnv (
150 tc_specs e rec_final_id ty_maybe specs
151 ) `thenB_Tc` \ spec_env ->
159 -- The strictness info *may* imply an unfolding
160 -- (the "wrapper_unfold"); that info is added; if
161 -- there is also an explicit unfolding, it will
162 -- take precedence, because it is "added" later.
163 `addInfo` strict_info
164 `addInfo_UF` wrapper_unfold_info
166 `addInfo_UF` unfold_info
170 get_arity Nothing = noInfo
171 get_arity (Just a) = mkArityInfo a
173 get_upd Nothing = noInfo
174 get_upd (Just u) = (u :: UpdateInfo)
177 Don't use the strictness info if a flag set.
182 -> Id -- final Id (do not *touch*)
183 -> ImpStrictness Name
184 -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
186 tc_strictness e ty_maybe rec_final_id info
187 = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
188 if sw_chkr IgnoreStrictnessPragmas then
189 returnB_Tc (noInfo, noInfo_UF)
191 do_strictness e ty_maybe rec_final_id info
196 do_strictness e ty_maybe rec_final_id NoImpStrictness
197 = returnB_Tc (noInfo, noInfo_UF)
200 We come to a nasty one now. We have strictness info---possibly
201 implying a worker---but (for whatever reason) no {\em type}
202 information for the wrapper. We therefore want (a)~{\em not} to
203 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
204 never asked for (!); and (b)~we want to keep the strictness/absence
205 info, because there's too much good stuff there to ignore completely.
206 We are not bothered about any pragmatic info for any alleged worker.
207 NB: this code applies only to {\em imported} info. So here we go:
210 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
214 then mkBottomStrictnessInfo
215 else mkStrictnessInfo arg_info Nothing
217 returnB_Tc (strictness_info, noInfo_UF)
218 -- no unfolding: the key --^^^^^^
221 And, finally, the have-everthing, know-everything, do-everything
224 do_strictness e (Just wrapper_ty) rec_final_id
225 (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
227 | is_bot -- it's a "bottoming Id"
228 = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
230 | not (indicatesWorker wrap_arg_info)
232 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
235 = -- Strictness info suggests a worker. Things could still
236 -- go wrong if there's an abstract type involved, mind you.
238 (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
239 n_wrapper_args = length wrap_arg_info
240 -- Don't have more args than this, else you risk
243 getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
244 getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
247 (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
249 inst_arg_tys = map (instantiateTy inst_env) arg_tys
250 (undropped_inst_arg_tys, dropped_inst_arg_tys)
251 = splitAt n_wrapper_args inst_arg_tys
253 inst_ret_ty = glueTyArgs dropped_inst_arg_tys
254 (instantiateTy inst_env ret_ty)
256 args = zipWithEqual mk_arg arg_uniqs undropped_inst_arg_tys
257 mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
258 -- ASSERT: length args = n_wrapper_args
261 uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
262 `thenB_Tc` \ result ->
265 Nothing -> -- Alas, we met an abstract type
266 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
268 Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
271 worker_ty = worker_ty_w_hole inst_ret_ty
273 getUniqueB_Tc `thenB_Tc` \ uniq ->
274 fixB_Tc ( \ rec_wrkr_id ->
279 wrkr_pragmas `thenB_Tc` \ wrkr_id_info ->
281 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
282 (wrkr_id_info `addInfo` worker_strictness))
283 -- Note: the above will *clobber* any strictness
284 -- info for the worker which was read in from the
285 -- interface (but there usually isn't any).
287 ) `thenB_Tc` \ worker_id ->
290 wrapper_rhs = wrapper_w_hole worker_id
291 n_tyvars = length tyvars
296 mkStrictnessInfo wrap_arg_info (Just worker_id),
297 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
298 -- We only do this for imported things, which this is.
304 -> Id -- final Id for which these are specialisations (do not *touch*)
306 -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
309 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
310 = returnB_Tc nullSpecEnv -- ToDo: msg????????
312 tc_specs e rec_main_id (Just main_ty) spec_pragmas
313 = mapB_Tc do_one_pragma spec_pragmas `thenB_Tc` \ spec_infos ->
314 returnB_Tc (mkSpecEnv spec_infos)
316 (main_tyvars, _) = splitForalls main_ty
321 do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
322 = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
323 `thenB_Tc` \ maybe_tys ->
324 getSrcLocB_Tc `thenB_Tc` \ locn ->
325 getUniqueB_Tc `thenB_Tc` \ uniq ->
327 checkB_Tc (length main_tyvars /= length maybe_tys)
328 (badSpecialisationErr "value" "wrong number of specialising types"
329 (length main_tyvars) maybe_tys locn)
332 spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
334 fixB_Tc ( \ rec_spec_id ->
336 tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
337 `thenB_Tc` \ spec_id_info ->
339 returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
341 ) `thenB_Tc` \ spec_id ->
343 returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
345 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
346 tc_ty_maybe rec_ce rec_tce (Just ty)
347 = tcMonoType rec_ce rec_tce nullTVE ty `thenB_Tc` \ new_ty ->
348 returnB_Tc (Just new_ty)
352 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
353 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
355 tc_unfolding e (ImpUnfolding guidance uf_core)
356 = tc_uf_core nullLVE nullTVE uf_core `thenB_Tc` \ core_expr ->
357 getSrcLocB_Tc `thenB_Tc` \ locn ->
359 -- Bad unfoldings are so painful that we always lint-check them,
360 -- marking them with BadUnfolding if lintUnfolding fails
361 -- NB: We cant check the lint result and return noInfo_UF if
362 -- lintUnfolding failed as this is too strict
363 -- Instead getInfo_UF tests for BadUnfolding and converts
364 -- to NoUnfoldingDetails when the unfolding is accessed
366 maybe_lint_expr = lintUnfolding locn core_expr
368 (lint_guidance, lint_expr) = case maybe_lint_expr of
369 Just lint_expr -> (guidance, lint_expr)
370 Nothing -> (BadUnfolding, panic_expr)
372 returnB_Tc (mkUnfolding lint_guidance lint_expr)
377 panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
379 tc_uf_core :: LVE -- lookup table for local binders
380 -- (others: we hope we can figure them out)
381 -> TVE -- lookup table for tyvars
382 -> UnfoldingCoreExpr Name
385 tc_uf_core lve tve (UfVar v)
386 = tc_uf_Id lve v `thenB_Tc` \ id ->
389 tc_uf_core lve tve (UfLit l)
392 tc_uf_core lve tve (UfCon con tys as)
393 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
394 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
395 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
396 returnB_Tc (Con con_id core_tys core_atoms)
398 -- If a ccall, we have to patch in the types read from the pragma.
400 tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
401 = ASSERT(null app_tys)
402 mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
403 tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
404 mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
405 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
406 returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
407 core_app_tys core_atoms)
409 tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
410 = mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
411 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
412 returnB_Tc (Prim op core_tys core_atoms)
414 tc_uf_core lve tve (UfLam binder body)
415 = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
417 [new_binder] = map snd lve2
418 new_lve = lve2 `plusLVE` lve
420 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
421 returnB_Tc (Lam new_binder new_body)
423 tc_uf_core lve tve (UfApp fun arg)
424 = tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
425 tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
426 returnB_Tc (App new_fun new_arg)
428 tc_uf_core lve tve (UfCase scrut alts)
429 = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
430 tc_alts alts `thenB_Tc` \ new_alts ->
431 returnB_Tc (Case new_scrut new_alts)
433 tc_alts (UfCoAlgAlts alts deflt)
434 = mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
435 tc_deflt deflt `thenB_Tc` \ new_deflt ->
436 returnB_Tc (AlgAlts new_alts new_deflt)
438 tc_alg_alt (con, params, rhs)
439 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
440 tc_uf_binders tve params `thenB_Tc` \ lve2 ->
442 new_params = map snd lve2
443 new_lve = lve2 `plusLVE` lve
445 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
446 returnB_Tc (con_id, new_params, new_rhs)
448 tc_alts (UfCoPrimAlts alts deflt)
449 = mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
450 tc_deflt deflt `thenB_Tc` \ new_deflt ->
451 returnB_Tc (PrimAlts new_alts new_deflt)
453 tc_prim_alt (lit, rhs)
454 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
455 returnB_Tc (lit, new_rhs)
457 tc_deflt UfCoNoDefault = returnB_Tc NoDefault
458 tc_deflt (UfCoBindDefault b rhs)
459 = tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
461 [new_b] = map snd lve2
462 new_lve = lve2 `plusLVE` lve
464 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
465 returnB_Tc (BindDefault new_b new_rhs)
467 tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
468 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
469 tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
471 [new_b] = map snd lve2
472 new_lve = lve2 `plusLVE` lve
474 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
475 returnB_Tc (Let (NonRec new_b new_rhs) new_body)
477 tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
479 (binders, rhss) = unzip pairs
481 tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
483 new_binders = map snd lve2
484 new_lve = lve2 `plusLVE` lve
486 mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
487 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
488 returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
490 tc_uf_core lve tve (UfSCC uf_cc body)
491 = tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
492 tc_uf_core lve tve body `thenB_Tc` \ new_body ->
493 returnB_Tc (SCC new_cc new_body)
495 tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
496 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
497 returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
499 tc_uf_cc (UfDictCC id m g is_dupd is_caf)
500 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
501 returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
503 tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
505 tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
506 tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
509 adjust is_caf is_dupd cc
511 maybe_cafify = if is_caf then cafifyCC else (\x->x)
512 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
514 maybe_dupify (maybe_cafify cc)
517 tc_uf_atom lve tve (UfCoLitAtom l)
518 = returnB_Tc (LitArg l)
520 tc_uf_atom lve tve (UfCoVarAtom v)
521 = tc_uf_Id lve v `thenB_Tc` \ new_v ->
522 returnB_Tc (VarArg new_v)
525 tc_uf_binders tve ids_and_tys
527 (ids, tys) = unzip ids_and_tys
529 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ new_tys ->
531 returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
534 -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
536 tc_uf_tyvar (Short u short_name)
538 tyvar = mkUserTyVar u short_name
540 (tyvar, u, mkTyVarTy tyvar)
543 tc_uf_Id lve (BoringUfId v)
544 = case (assocMaybe lve v) of
545 Just xx -> returnB_Tc xx
546 Nothing -> case (lookupE_ValueQuietly e v) of
547 Just xx -> returnB_Tc xx
548 Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
549 -- (ppCat [ppStr "Failed lookup for BoringUfId:",
551 (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
552 -- will be recover'd from
553 -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
555 tc_uf_Id lve (SuperDictSelUfId c sc)
557 clas = lookupCE rec_ce c
558 super_clas = lookupCE rec_ce sc
560 returnB_Tc (classSuperDictSelId clas super_clas)
562 tc_uf_Id lve (ClassOpUfId c op_name)
564 clas = lookupCE rec_ce c
565 op = lookup_class_op clas op_name
567 returnB_Tc (classOpId clas op)
569 tc_uf_Id lve (DefaultMethodUfId c op_name)
571 clas = lookupCE rec_ce c
572 op = lookup_class_op clas op_name
574 returnB_Tc (classDefaultMethodId clas op)
576 tc_uf_Id lve uf_id@(DictFunUfId c ty)
577 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
579 clas = lookupCE rec_ce c
580 dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
582 Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
583 (ppr PprDebug (UfVar uf_id))
584 -- The class and type are both
585 -- visible, so the instance should
586 -- jolly well be too!
590 tc_uf_Id lve (ConstMethodUfId c op_name ty)
591 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
593 clas = lookupCE rec_ce c
594 op = lookup_class_op clas op_name
596 returnB_Tc (getConstMethodId clas op new_ty)
598 tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
599 = tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
600 mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
601 `thenB_Tc` \ maybe_tys ->
603 spec_id = lookupSpecId unspec_id maybe_tys
607 tc_uf_Id lve (WorkerUfId unwrkr)
608 = tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
610 strictness_info = getIdStrictness unwrkr_id
612 if isLocallyDefined unwrkr_id
614 -- A locally defined value will not have any strictness info (yet),
615 -- so we can't extract the locally defined worker Id from it :-(
617 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
618 (ppCat [ppStr "Worker Id in unfolding is defined locally:",
619 ppr PprDebug unwrkr_id])
620 (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
621 -- will be recover'd from
623 returnB_Tc (getWorkerId strictness_info)
626 lookup_class_op clas (ClassOpName _ _ _ tag)
627 = classOps clas !! (tag - 1)
629 ---------------------------------------------------------------------
630 tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
632 tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
635 %************************************************************************
637 \subsection[tcDataPragmas]{@data@ type pragmas}
639 %************************************************************************
641 The purpose of a @data@ pragma is to convey data-constructor
642 information that would otherwise be unknown.
644 It also records specialisation information which is added to each data
645 constructor. This info just contains the type info for the
646 specialisations which exist. No specialised Ids are actually created.
649 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
650 -> RenamedDataPragmas
651 -> Baby_TcM ([RenamedConDecl], -- any pragma condecls
652 [SpecInfo]) -- specialisation info from pragmas
654 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
655 = mapB_Tc do_one_spec specs `thenB_Tc` \ spec_infos ->
656 returnB_Tc (con_decls, spec_infos)
658 do_one_spec maybe_monotys
659 = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
660 `thenB_Tc` \ maybe_tys ->
661 getSrcLocB_Tc `thenB_Tc` \ locn ->
663 checkB_Tc (length new_tyvars /= length maybe_tys)
664 (badSpecialisationErr "data" "wrong number of specialising types"
665 (length new_tyvars) maybe_tys locn)
668 checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
669 (badSpecialisationErr "data" "not all unboxed types"
670 (length new_tyvars) maybe_tys locn)
673 returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))