ghc/compiler/typecheck/TcPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcPragmas (
  10         tcClassOpPragmas,
  11         tcDataPragmas,
  12         tcDictFunPragmas,
  13         tcGenPragmas,
  14         tcTypePragmas
  15     ) where
  16
  17 IMPORT_Trace    -- ToDo: rm (debugging)
  18 import Pretty
  19 import Outputable
  20
  21 import TcMonad          -- typechecking monadic machinery
  22 import TcMonadFns       ( mkIdsWithGivenTys )
  23 import AbsSyn           -- the stuff being typechecked
  24
  25 import AbsPrel          ( PrimOp(..)    -- to see CCallOp
  26                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  27                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  28                         )
  29 import AbsUniType
  30 import CE               ( lookupCE, nullCE, CE(..) )
  31 import CmdLineOpts
  32 import CostCentre
  33 import E
  34 import Errors
  35 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  36 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  37 import Id
  38 import IdInfo
  39 import WwLib            ( mkWwBodies )
  40 import InstEnv          ( lookupClassInstAtSimpleType )
  41 import Maybes           ( assocMaybe, catMaybes, Maybe(..) )
  42 import CoreLint         ( lintUnfolding )
  43 import PlainCore
  44 import TCE              ( TCE(..), UniqFM )
  45 import TVE
  46 import TcMonoType       ( tcMonoType )
  47 import TcPolyType       ( tcPolyType )
  48 import Util
  49 import SrcLoc
  50 \end{code}
  51
  52 The basic idea is: Given an @Id@ that only lacks its @IdInfo@
  53 (represented as a function \tr{IdInfo -> Id}, use the pragmas given to
  54 figure out the @IdInfo@, then give back the now-complete @Id@.
  55
  56 Of course, the pragmas also need to be checked.
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 tcClassOpPragmas :: E                   -- Class/TyCon lookup tables
  66              -> UniType                 -- global type of the class method
  67              -> Id                      -- *final* ClassOpId
  68              -> Id                      -- *final* DefaultMethodId
  69              -> SpecEnv                 -- Instance info for this class op
  70              -> RenamedClassOpPragmas   -- info w/ which to complete, giving...
  71              -> Baby_TcM (IdInfo, IdInfo)       -- ... final info for ClassOp and DefaultMethod
  72
  73 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
  74   = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
  75
  76 tcClassOpPragmas e global_ty
  77                  rec_classop_id rec_defm_id
  78                  spec_infos
  79                  (ClassOpPragmas classop_pragmas defm_pragmas)
  80   = tcGenPragmas e
  81                  Nothing{-ty unknown-} rec_classop_id
  82                  classop_pragmas        `thenB_Tc` \ classop_idinfo ->
  83
  84     tcGenPragmas e
  85                  Nothing{-ty unknown-} rec_defm_id
  86                  defm_pragmas           `thenB_Tc` \ defm_idinfo ->
  87
  88     returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 {\em Every} instance declaration produces a ``dictionary function''
  98 (dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
  99 convey information about a DictFunId.
 100
 101 \begin{code}
 102 tcDictFunPragmas
 103         :: E                        -- Class/TyCon lookup tables
 104         -> UniType                  -- DictFunId type
 105         -> Id                       -- final DictFunId (don't touch)
 106         -> RenamedInstancePragmas   -- info w/ which to complete, giving...
 107         -> Baby_TcM IdInfo          -- ... final DictFun IdInfo
 108
 109 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
 110   = returnB_Tc noIdInfo
 111
 112 tcDictFunPragmas e dfun_ty final_dfun pragmas
 113   = let
 114         dfun_pragmas
 115           = case pragmas of
 116               SimpleInstancePragma      x   -> x
 117               ConstantInstancePragma    x _ -> x
 118               SpecialisedInstancePragma x _ -> x
 119     in
 120     tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection[tcGenPragmas]{Basic pragmas about a value}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
 130 a problem, it just returns @noIdInfo@.
 131
 132 \begin{code}
 133 tcGenPragmas
 134         :: E                    -- lookup table
 135         -> Maybe UniType        -- of Id, if we have it (for convenience)
 136         -> Id                   -- *incomplete* Id (do not *touch*!)
 137         -> RenamedGenPragmas    -- info w/ which to complete, giving...
 138         -> Baby_TcM IdInfo      -- IdInfo for this Id
 139
 140 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
 141   = returnB_Tc noIdInfo
 142
 143 tcGenPragmas e ty_maybe rec_final_id
 144              (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
 145   =     -- Guarantee success!
 146     recoverIgnoreErrorsB_Tc noIdInfo (
 147
 148         -- OK, now we do the business
 149     let
 150         arity_info  = get_arity  arity_maybe
 151         upd_info    = get_upd    upd_maybe
 152     in
 153     tc_strictness e ty_maybe rec_final_id strictness
 154                                 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
 155
 156         -- If the unfolding fails to look consistent, we don't
 157         -- want to junk *all* the IdInfo
 158     recoverIgnoreErrorsB_Tc noInfo_UF (
 159         tc_unfolding e unfold
 160     )                           `thenB_Tc` \ unfold_info ->
 161
 162         -- Same as unfolding; if we fail, don't junk all IdInfo
 163     recoverIgnoreErrorsB_Tc nullSpecEnv (
 164         tc_specs e rec_final_id ty_maybe specs
 165     )                           `thenB_Tc` \ spec_env ->
 166
 167     returnB_Tc (
 168         noIdInfo
 169         `addInfo` arity_info
 170         `addInfo` upd_info
 171         `addInfo` def
 172
 173             -- The strictness info *may* imply an unfolding
 174             -- (the "wrapper_unfold"); that info is added; if
 175             -- there is also an explicit unfolding, it will
 176             -- take precedence, because it is "added" later.
 177         `addInfo` strict_info
 178         `addInfo_UF` wrapper_unfold_info
 179
 180         `addInfo_UF` unfold_info
 181         `addInfo` spec_env
 182     ))
 183   where
 184     get_arity Nothing  = noInfo
 185     get_arity (Just a) = mkArityInfo a
 186
 187     get_upd Nothing  = noInfo
 188     get_upd (Just u) = (u :: UpdateInfo)
 189 \end{code}
 190
 191 Don't use the strictness info if a flag set.
 192 \begin{code}
 193 tc_strictness
 194         :: E
 195         -> Maybe UniType
 196         -> Id           -- final Id (do not *touch*)
 197         -> ImpStrictness Name
 198         -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
 199
 200 tc_strictness e ty_maybe rec_final_id info
 201   = getSwitchCheckerB_Tc    `thenB_Tc` \ sw_chkr ->
 202     if sw_chkr IgnoreStrictnessPragmas then
 203         returnB_Tc (noInfo, noInfo_UF)
 204     else
 205         do_strictness e ty_maybe rec_final_id info
 206 \end{code}
 207
 208 An easy one first:
 209 \begin{code}
 210 do_strictness e ty_maybe rec_final_id NoImpStrictness
 211   = returnB_Tc (noInfo, noInfo_UF)
 212 \end{code}
 213
 214 We come to a nasty one now.  We have strictness info---possibly
 215 implying a worker---but (for whatever reason) no {\em type}
 216 information for the wrapper.  We therefore want (a)~{\em not} to
 217 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
 218 never asked for (!); and (b)~we want to keep the strictness/absence
 219 info, because there's too much good stuff there to ignore completely.
 220 We are not bothered about any pragmatic info for any alleged worker.
 221 NB: this code applies only to {\em imported} info.  So here we go:
 222
 223 \begin{code}
 224 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
 225   = let
 226         strictness_info
 227           = if is_bot
 228             then mkBottomStrictnessInfo
 229             else mkStrictnessInfo arg_info Nothing
 230     in
 231     returnB_Tc (strictness_info, noInfo_UF)
 232       -- no unfolding: the key --^^^^^^
 233 \end{code}
 234
 235 And, finally, the have-everthing, know-everything, do-everything
 236 ``normal case''.
 237 \begin{code}
 238 do_strictness e (Just wrapper_ty) rec_final_id
 239               (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
 240
 241   | is_bot -- it's a "bottoming Id"
 242   = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
 243
 244   | not (indicatesWorker wrap_arg_info)
 245   = -- No worker
 246     returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 247
 248   | otherwise
 249   = -- Strictness info suggests a worker.  Things could still
 250     -- go wrong if there's an abstract type involved, mind you.
 251     let
 252         (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
 253         n_wrapper_args              = length wrap_arg_info
 254                 -- Don't have more args than this, else you risk
 255                 -- losing laziness!!
 256     in
 257     getUniquesB_Tc (length tv_tmpls)    `thenB_Tc` \ tyvar_uniqs ->
 258     getUniquesB_Tc n_wrapper_args       `thenB_Tc` \ arg_uniqs ->
 259
 260     let
 261         (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
 262
 263         inst_arg_tys = map (instantiateTy inst_env) arg_tys
 264         (undropped_inst_arg_tys, dropped_inst_arg_tys)
 265           = splitAt n_wrapper_args inst_arg_tys
 266
 267         inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 268                                   (instantiateTy inst_env ret_ty)
 269
 270         args         = zipWith mk_arg arg_uniqs undropped_inst_arg_tys
 271         mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
 272         -- ASSERT: length args = n_wrapper_args
 273     in
 274
 275     uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
 276                                                         `thenB_Tc` \ result ->
 277     case result of
 278
 279         Nothing ->      -- Alas, we met an abstract type
 280             returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 281
 282         Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 283
 284             let
 285                 worker_ty   = worker_ty_w_hole inst_ret_ty
 286             in
 287             getUniqueB_Tc `thenB_Tc` \ uniq ->
 288             fixB_Tc ( \ rec_wrkr_id ->
 289
 290                 tcGenPragmas e
 291                          (Just worker_ty)
 292                          rec_wrkr_id
 293                          wrkr_pragmas   `thenB_Tc` \ wrkr_id_info ->
 294
 295                 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
 296                                 (wrkr_id_info `addInfo` worker_strictness))
 297                         -- Note: the above will *clobber* any strictness
 298                         -- info for the worker which was read in from the
 299                         -- interface (but there usually isn't any).
 300
 301             ) `thenB_Tc` \ worker_id ->
 302
 303             let
 304                 wrapper_rhs = wrapper_w_hole worker_id
 305                 n_tyvars    = length tyvars
 306                 arity       = length args
 307
 308             in
 309             returnB_Tc (
 310                 mkStrictnessInfo wrap_arg_info (Just worker_id),
 311                 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
 312                     -- We only do this for imported things, which this is.
 313             )
 314 \end{code}
 315
 316 \begin{code}
 317 tc_specs :: E
 318          -> Id -- final Id for which these are specialisations (do not *touch*)
 319          -> Maybe UniType
 320          -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
 321          -> Baby_TcM SpecEnv
 322
 323 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
 324   = returnB_Tc nullSpecEnv  -- ToDo: msg????????
 325
 326 tc_specs e rec_main_id (Just main_ty) spec_pragmas
 327   = mapB_Tc do_one_pragma spec_pragmas  `thenB_Tc` \ spec_infos ->
 328     returnB_Tc (mkSpecEnv spec_infos)
 329   where
 330     (main_tyvars, _) = splitForalls main_ty
 331
 332     rec_ce  = getE_CE  e
 333     rec_tce = getE_TCE e
 334
 335     do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
 336       = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
 337                                 `thenB_Tc` \ maybe_tys ->
 338         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 339         getUniqueB_Tc           `thenB_Tc` \ uniq ->
 340
 341         checkB_Tc (length main_tyvars /= length maybe_tys)
 342                 (badSpecialisationErr "value" "wrong number of specialising types"
 343                                       (length main_tyvars) maybe_tys locn)
 344                                 `thenB_Tc_`
 345         let
 346             spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
 347         in
 348         fixB_Tc ( \ rec_spec_id ->
 349
 350             tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
 351                 `thenB_Tc` \ spec_id_info ->
 352
 353             returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
 354
 355         ) `thenB_Tc` \ spec_id ->
 356
 357         returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
 358
 359 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
 360 tc_ty_maybe rec_ce rec_tce (Just ty)
 361   = tcMonoType rec_ce rec_tce nullTVE ty        `thenB_Tc` \ new_ty ->
 362     returnB_Tc (Just new_ty)
 363 \end{code}
 364
 365 \begin{code}
 366 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
 367 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
 368
 369 tc_unfolding e (ImpUnfolding guidance uf_core)
 370   = tc_uf_core nullLVE nullTVE uf_core  `thenB_Tc` \ core_expr ->
 371     getSrcLocB_Tc                       `thenB_Tc` \ locn ->
 372     let
 373         -- Bad unfoldings are so painful that we always lint-check them,
 374         -- marking them with BadUnfolding if lintUnfolding fails
 375         -- NB: We cant check the lint result and return noInfo_UF if
 376         --     lintUnfolding failed as this is too strict
 377         --     Instead getInfo_UF tests for BadUnfolding and converts
 378         --     to NoUnfoldingDetails when the unfolding is accessed
 379
 380         maybe_lint_expr = lintUnfolding locn core_expr
 381
 382         (lint_guidance, lint_expr) = case maybe_lint_expr of
 383           Just lint_expr -> (guidance, lint_expr)
 384           Nothing        -> (BadUnfolding, panic_expr)
 385     in
 386     returnB_Tc (mkUnfolding lint_guidance lint_expr)
 387   where
 388     rec_ce  = getE_CE  e
 389     rec_tce = getE_TCE e
 390
 391     panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
 392
 393     tc_uf_core :: LVE       -- lookup table for local binders
 394                             -- (others: we hope we can figure them out)
 395                -> TVE       -- lookup table for tyvars
 396                -> UnfoldingCoreExpr Name
 397                -> Baby_TcM PlainCoreExpr
 398
 399     tc_uf_core lve tve (UfCoVar v)
 400       = tc_uf_Id lve v          `thenB_Tc` \ id ->
 401         returnB_Tc (CoVar id)
 402
 403     tc_uf_core lve tve (UfCoLit l)
 404       = returnB_Tc (CoLit l)
 405
 406     tc_uf_core lve tve (UfCoCon con tys as)
 407       = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 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 (CoCon con_id core_tys core_atoms)
 411
 412     --  If a ccall, we have to patch in the types read from the pragma.
 413
 414     tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
 415       = ASSERT(null app_tys)
 416         mapB_Tc (tc_uf_type tve) arg_tys        `thenB_Tc` \ core_arg_tys ->
 417         tc_uf_type tve res_ty           `thenB_Tc` \ core_res_ty ->
 418         mapB_Tc (tc_uf_type tve) app_tys        `thenB_Tc` \ core_app_tys ->
 419         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 420         returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
 421                          core_app_tys core_atoms)
 422
 423     tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
 424       = mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ core_tys ->
 425         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 426         returnB_Tc (CoPrim op core_tys core_atoms)
 427
 428     tc_uf_core lve tve (UfCoLam binders body)
 429       = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
 430         let
 431             new_binders = map snd lve2
 432             new_lve     = lve2 `plusLVE` lve
 433         in
 434         tc_uf_core new_lve tve body      `thenB_Tc` \ new_body ->
 435         returnB_Tc (CoLam new_binders new_body)
 436
 437     tc_uf_core lve tve (UfCoTyLam tv body)
 438       = let
 439             (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
 440             new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
 441         in
 442         tc_uf_core lve new_tve body      `thenB_Tc` \ new_body ->
 443         returnB_Tc (CoTyLam new_tv new_body)
 444
 445     tc_uf_core lve tve (UfCoApp fun arg)
 446       = tc_uf_core lve tve fun  `thenB_Tc` \ new_fun ->
 447         tc_uf_atom lve tve arg  `thenB_Tc` \ new_arg ->
 448         returnB_Tc (CoApp new_fun new_arg)
 449
 450     tc_uf_core lve tve (UfCoTyApp expr ty)
 451       = tc_uf_core lve tve expr `thenB_Tc` \ new_expr ->
 452         tc_uf_type tve ty       `thenB_Tc` \ new_ty ->
 453         returnB_Tc (mkCoTyApp new_expr new_ty)
 454
 455     tc_uf_core lve tve (UfCoCase scrut alts)
 456       = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
 457         tc_alts alts             `thenB_Tc` \ new_alts ->
 458         returnB_Tc (CoCase new_scrut new_alts)
 459       where
 460         tc_alts (UfCoAlgAlts alts deflt)
 461           = mapB_Tc tc_alg_alt alts   `thenB_Tc` \ new_alts ->
 462             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 463             returnB_Tc (CoAlgAlts new_alts new_deflt)
 464           where
 465             tc_alg_alt (con, params, rhs)
 466               = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 467                 tc_uf_binders tve params        `thenB_Tc` \ lve2 ->
 468                 let
 469                     new_params = map snd lve2
 470                     new_lve    = lve2 `plusLVE` lve
 471                 in
 472                 tc_uf_core new_lve tve rhs      `thenB_Tc` \ new_rhs ->
 473                 returnB_Tc (con_id, new_params, new_rhs)
 474
 475         tc_alts (UfCoPrimAlts alts deflt)
 476           = mapB_Tc tc_prim_alt alts  `thenB_Tc` \ new_alts ->
 477             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 478             returnB_Tc (CoPrimAlts new_alts new_deflt)
 479           where
 480             tc_prim_alt (lit, rhs)
 481               = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 482                 returnB_Tc (lit, new_rhs)
 483
 484         tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
 485         tc_deflt (UfCoBindDefault b rhs)
 486           = tc_uf_binders tve [b]       `thenB_Tc` \ lve2 ->
 487             let
 488                 [new_b] = map snd lve2
 489                 new_lve = lve2 `plusLVE` lve
 490             in
 491             tc_uf_core new_lve tve rhs  `thenB_Tc` \ new_rhs ->
 492             returnB_Tc (CoBindDefault new_b new_rhs)
 493
 494     tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
 495       = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 496         tc_uf_binders tve [b]   `thenB_Tc` \ lve2 ->
 497         let
 498             [new_b] = map snd lve2
 499             new_lve = lve2 `plusLVE` lve
 500         in
 501         tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
 502         returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
 503
 504     tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
 505       = let
 506             (binders, rhss) = unzip pairs
 507         in
 508         tc_uf_binders tve binders   `thenB_Tc` \ lve2 ->
 509         let
 510             new_binders = map snd lve2
 511             new_lve     = lve2 `plusLVE` lve
 512         in
 513         mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
 514         tc_uf_core new_lve tve         body `thenB_Tc` \ new_body ->
 515         returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
 516
 517     tc_uf_core lve tve (UfCoSCC uf_cc body)
 518       = tc_uf_cc   uf_cc            `thenB_Tc` \ new_cc ->
 519         tc_uf_core lve tve body     `thenB_Tc` \ new_body ->
 520         returnB_Tc (CoSCC new_cc new_body)
 521       where
 522         tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
 523           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 524             returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
 525
 526         tc_uf_cc (UfDictCC id m g is_dupd is_caf)
 527           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 528             returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
 529
 530         tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
 531
 532         tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
 533         tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
 534
 535         --------
 536         adjust is_caf is_dupd cc
 537           = let
 538                 maybe_cafify = if is_caf  then cafifyCC else (\x->x)
 539                 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
 540             in
 541             maybe_dupify (maybe_cafify cc)
 542
 543     ---------------
 544     tc_uf_atom lve tve (UfCoLitAtom l)
 545       = returnB_Tc (CoLitAtom l)
 546
 547     tc_uf_atom lve tve (UfCoVarAtom v)
 548       = tc_uf_Id lve v                  `thenB_Tc` \ new_v ->
 549         returnB_Tc (CoVarAtom new_v)
 550
 551     ---------------
 552     tc_uf_binders tve ids_and_tys
 553       = let
 554             (ids, tys) = unzip ids_and_tys
 555         in
 556         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ new_tys ->
 557
 558         returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
 559
 560     ---------------
 561     -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
 562
 563     tc_uf_tyvar (Short u short_name)
 564       = let
 565             tyvar = mkUserTyVar u short_name
 566         in
 567         (tyvar, u, mkTyVarTy tyvar)
 568
 569     ---------------
 570     tc_uf_Id lve (BoringUfId v)
 571       = case (assocMaybe lve v) of
 572           Just xx -> returnB_Tc xx
 573           Nothing -> case (lookupE_ValueQuietly e v) of
 574                        Just xx -> returnB_Tc xx
 575                        Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 576                                   --       (ppCat [ppStr "Failed lookup for BoringUfId:",
 577                                   --               ppr PprDebug v])
 578                                   (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
 579                                   -- will be recover'd from
 580                                   -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
 581
 582     tc_uf_Id lve (SuperDictSelUfId c sc)
 583       = let
 584             clas       = lookupCE rec_ce c
 585             super_clas = lookupCE rec_ce sc
 586         in
 587         returnB_Tc (getSuperDictSelId clas super_clas)
 588
 589     tc_uf_Id lve (ClassOpUfId c op_name)
 590       = let
 591             clas = lookupCE rec_ce c
 592             op   = lookup_class_op clas op_name
 593         in
 594         returnB_Tc (getClassOpId clas op)
 595
 596     tc_uf_Id lve (DefaultMethodUfId c op_name)
 597       = let
 598             clas = lookupCE rec_ce c
 599             op   = lookup_class_op clas op_name
 600         in
 601         returnB_Tc (getDefaultMethodId clas op)
 602
 603     tc_uf_Id lve uf_id@(DictFunUfId c ty)
 604       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 605         let
 606             clas = lookupCE rec_ce c
 607             dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
 608                           Just id -> id
 609                           Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
 610                                         (ppr PprDebug (UfCoVar uf_id))
 611                                         -- The class and type are both
 612                                         -- visible, so the instance should
 613                                         -- jolly well be too!
 614         in
 615         returnB_Tc dfun_id
 616
 617     tc_uf_Id lve (ConstMethodUfId c op_name ty)
 618       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 619         let
 620             clas = lookupCE rec_ce c
 621             op   = lookup_class_op clas op_name
 622         in
 623         returnB_Tc (getConstMethodId clas op new_ty)
 624
 625     tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
 626       = tc_uf_Id lve unspec         `thenB_Tc` \ unspec_id ->
 627         mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
 628                                     `thenB_Tc` \ maybe_tys ->
 629         let
 630            spec_id = lookupSpecId unspec_id maybe_tys
 631         in
 632         returnB_Tc spec_id
 633
 634     tc_uf_Id lve (WorkerUfId unwrkr)
 635       = tc_uf_Id lve unwrkr     `thenB_Tc` \ unwrkr_id ->
 636         let
 637             strictness_info = getIdStrictness unwrkr_id
 638         in
 639         if isLocallyDefined unwrkr_id
 640         then
 641             -- A locally defined value will not have any strictness info (yet),
 642             -- so we can't extract the locally defined worker Id from it :-(
 643
 644             pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 645                      (ppCat [ppStr "Worker Id in unfolding is defined locally:",
 646                              ppr PprDebug unwrkr_id])
 647             (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
 648             -- will be recover'd from
 649         else
 650             returnB_Tc (getWorkerId strictness_info)
 651
 652     ---------------
 653     lookup_class_op clas (ClassOpName _ _ _ tag)
 654       = getClassOps clas !! (tag - 1)
 655
 656     ---------------------------------------------------------------------
 657     tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
 658
 659     tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection[tcDataPragmas]{@data@ type pragmas}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 The purpose of a @data@ pragma is to convey data-constructor
 669 information that would otherwise be unknown.
 670
 671 It also records specialisation information which is added to each data
 672 constructor. This info just contains the type info for the
 673 specialisations which exist. No specialised Ids are actually created.
 674
 675 \begin{code}
 676 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
 677               -> RenamedDataPragmas
 678               -> Baby_TcM ([RenamedConDecl],    -- any pragma condecls
 679                            [SpecInfo])          -- specialisation info from pragmas
 680
 681 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
 682   = mapB_Tc do_one_spec specs           `thenB_Tc` \ spec_infos ->
 683     returnB_Tc (con_decls, spec_infos)
 684   where
 685     do_one_spec maybe_monotys
 686       = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
 687                                 `thenB_Tc` \ maybe_tys ->
 688         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 689
 690         checkB_Tc (length new_tyvars /= length maybe_tys)
 691                 (badSpecialisationErr "data" "wrong number of specialising types"
 692                                       (length new_tyvars) maybe_tys locn)
 693                                 `thenB_Tc_`
 694
 695         checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys)))
 696                 (badSpecialisationErr "data" "not all unboxed types"
 697                                       (length new_tyvars) maybe_tys locn)
 698                                 `thenB_Tc_`
 699
 700         returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
 701 \end{code}
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsection[tcTypePragmas]{@type@ synonym pragmas}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 The purpose of a @type@ pragma is to say that the synonym's
 710 representation should not be used by the user.
 711
 712 \begin{code}
 713 tcTypePragmas :: TypePragmas
 714               -> Bool           -- True <=> abstract synonym, please
 715
 716 tcTypePragmas NoTypePragmas     = False
 717 tcTypePragmas AbstractTySynonym = True
 718 \end{code}
 719