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
 154         -- If the unfolding fails to look consistent, we don't
 155         -- want to junk *all* the IdInfo
 156     recoverIgnoreErrorsB_Tc noInfo_UF (
 157         tc_unfolding e unfold
 158     )                           `thenB_Tc` \ unfold_info ->
 159
 160     tc_strictness e ty_maybe rec_final_id strictness
 161                                 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
 162
 163         -- Same as unfolding; if we fail, don't junk all IdInfo
 164     recoverIgnoreErrorsB_Tc nullSpecEnv (
 165         tc_specs e rec_final_id ty_maybe specs
 166     )                           `thenB_Tc` \ spec_env ->
 167
 168     returnB_Tc (
 169         noIdInfo
 170         `addInfo` arity_info
 171         `addInfo` upd_info
 172         `addInfo` def
 173
 174             -- The strictness info *may* imply an unfolding
 175             -- (the "wrapper_unfold"); that info is added; if
 176             -- there is also an explicit unfolding, it will
 177             -- take precedence, because it is "added" later.
 178         `addInfo` strict_info
 179         `addInfo_UF` wrapper_unfold_info
 180
 181         `addInfo_UF` unfold_info
 182         `addInfo` spec_env
 183     ))
 184   where
 185     get_arity Nothing  = noInfo
 186     get_arity (Just a) = mkArityInfo a
 187
 188     get_upd Nothing  = noInfo
 189     get_upd (Just u) = (u :: UpdateInfo)
 190 \end{code}
 191
 192 Don't use the strictness info if a flag set.
 193 \begin{code}
 194 tc_strictness
 195         :: E
 196         -> Maybe UniType
 197         -> Id           -- final Id (do not *touch*)
 198         -> ImpStrictness Name
 199         -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
 200
 201 tc_strictness e ty_maybe rec_final_id info
 202   = getSwitchCheckerB_Tc    `thenB_Tc` \ sw_chkr ->
 203     if sw_chkr IgnoreStrictnessPragmas then
 204         returnB_Tc (noInfo, noInfo_UF)
 205     else
 206         do_strictness e ty_maybe rec_final_id info
 207 \end{code}
 208
 209 An easy one first:
 210 \begin{code}
 211 do_strictness e ty_maybe rec_final_id NoImpStrictness
 212   = returnB_Tc (noInfo, noInfo_UF)
 213 \end{code}
 214
 215 We come to a nasty one now.  We have strictness info---possibly
 216 implying a worker---but (for whatever reason) no {\em type}
 217 information for the wrapper.  We therefore want (a)~{\em not} to
 218 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
 219 never asked for (!); and (b)~we want to keep the strictness/absence
 220 info, because there's too much good stuff there to ignore completely.
 221 We are not bothered about any pragmatic info for any alleged worker.
 222 NB: this code applies only to {\em imported} info.  So here we go:
 223
 224 \begin{code}
 225 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
 226   = let
 227         strictness_info
 228           = if is_bot
 229             then mkBottomStrictnessInfo
 230             else mkStrictnessInfo arg_info Nothing
 231     in
 232     returnB_Tc (strictness_info, noInfo_UF)
 233       -- no unfolding: the key --^^^^^^
 234 \end{code}
 235
 236 And, finally, the have-everthing, know-everything, do-everything
 237 ``normal case''.
 238 \begin{code}
 239 do_strictness e (Just wrapper_ty) rec_final_id
 240               (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
 241
 242   | is_bot -- it's a "bottoming Id"
 243   = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
 244
 245   | not (indicatesWorker wrap_arg_info)
 246   = -- No worker
 247     returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 248
 249   | otherwise
 250   = -- Strictness info suggests a worker.  Things could still
 251     -- go wrong if there's an abstract type involved, mind you.
 252     let
 253         (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
 254         n_wrapper_args              = length wrap_arg_info
 255                 -- Don't have more args than this, else you risk
 256                 -- losing laziness!!
 257     in
 258     getUniquesB_Tc (length tv_tmpls)    `thenB_Tc` \ tyvar_uniqs ->
 259     getUniquesB_Tc n_wrapper_args       `thenB_Tc` \ arg_uniqs ->
 260
 261     let
 262         (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
 263
 264         inst_arg_tys = map (instantiateTy inst_env) arg_tys
 265         (undropped_inst_arg_tys, dropped_inst_arg_tys)
 266           = splitAt n_wrapper_args inst_arg_tys
 267
 268         inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 269                                   (instantiateTy inst_env ret_ty)
 270
 271         args         = zipWith mk_arg arg_uniqs undropped_inst_arg_tys
 272         mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
 273         -- ASSERT: length args = n_wrapper_args
 274     in
 275
 276     uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
 277                                                         `thenB_Tc` \ result ->
 278     case result of
 279
 280         Nothing ->      -- Alas, we met an abstract type
 281             returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 282
 283         Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 284
 285             let
 286                 worker_ty   = worker_ty_w_hole inst_ret_ty
 287             in
 288             getUniqueB_Tc `thenB_Tc` \ uniq ->
 289             fixB_Tc ( \ rec_wrkr_id ->
 290
 291                 tcGenPragmas e
 292                          (Just worker_ty)
 293                          rec_wrkr_id
 294                          wrkr_pragmas   `thenB_Tc` \ wrkr_id_info ->
 295
 296                 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
 297                                 (wrkr_id_info `addInfo` worker_strictness))
 298                         -- Note: the above will *clobber* any strictness
 299                         -- info for the worker which was read in from the
 300                         -- interface (but there usually isn't any).
 301
 302             ) `thenB_Tc` \ worker_id ->
 303
 304             let
 305                 wrapper_rhs = wrapper_w_hole worker_id
 306                 n_tyvars    = length tyvars
 307                 arity       = length args
 308
 309             in
 310             returnB_Tc (
 311                 mkStrictnessInfo wrap_arg_info (Just worker_id),
 312                 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
 313                     -- We only do this for imported things, which this is.
 314             )
 315 \end{code}
 316
 317 \begin{code}
 318 tc_specs :: E
 319          -> Id -- final Id for which these are specialisations (do not *touch*)
 320          -> Maybe UniType
 321          -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
 322          -> Baby_TcM SpecEnv
 323
 324 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
 325   = returnB_Tc nullSpecEnv  -- ToDo: msg????????
 326
 327 tc_specs e rec_main_id (Just main_ty) spec_pragmas
 328   = mapB_Tc do_one_pragma spec_pragmas  `thenB_Tc` \ spec_infos ->
 329     returnB_Tc (mkSpecEnv spec_infos)
 330   where
 331     (main_tyvars, _) = splitForalls main_ty
 332
 333     rec_ce  = getE_CE  e
 334     rec_tce = getE_TCE e
 335
 336     do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
 337       = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
 338                                 `thenB_Tc` \ maybe_tys ->
 339         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 340         getUniqueB_Tc           `thenB_Tc` \ uniq ->
 341
 342         checkB_Tc (length main_tyvars /= length maybe_tys)
 343                 (badSpecialisationErr "value" "wrong number of specialising types"
 344                                       (length main_tyvars) maybe_tys locn)
 345                                 `thenB_Tc_`
 346         let
 347             spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
 348         in
 349         fixB_Tc ( \ rec_spec_id ->
 350
 351             tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
 352                 `thenB_Tc` \ spec_id_info ->
 353
 354             returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
 355
 356         ) `thenB_Tc` \ spec_id ->
 357
 358         returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
 359
 360 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
 361 tc_ty_maybe rec_ce rec_tce (Just ty)
 362   = tcMonoType rec_ce rec_tce nullTVE ty        `thenB_Tc` \ new_ty ->
 363     returnB_Tc (Just new_ty)
 364 \end{code}
 365
 366 \begin{code}
 367 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
 368 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
 369
 370 tc_unfolding e (ImpUnfolding guidance uf_core)
 371   = tc_uf_core nullLVE nullTVE uf_core  `thenB_Tc` \ core_expr ->
 372     getSrcLocB_Tc                       `thenB_Tc` \ locn ->
 373     returnB_Tc (mkUnfolding guidance (lintUnfolding locn core_expr))
 374     -- type-incorrect unfoldings are so painful that we
 375     -- always lint-check them; such unfoldings can arise
 376     -- because of by-hand mix-and-match jiggery-pokery with
 377     -- interface files (WDP 95/05)
 378   where
 379     rec_ce  = getE_CE  e
 380     rec_tce = getE_TCE e
 381
 382     tc_uf_core :: LVE       -- lookup table for local binders
 383                             -- (others: we hope we can figure them out)
 384                -> TVE       -- lookup table for tyvars
 385                -> UnfoldingCoreExpr Name
 386                -> Baby_TcM PlainCoreExpr
 387
 388     tc_uf_core lve tve (UfCoVar v)
 389       = tc_uf_Id lve v          `thenB_Tc` \ id ->
 390         returnB_Tc (CoVar id)
 391
 392     tc_uf_core lve tve (UfCoLit l)
 393       = returnB_Tc (CoLit l)
 394
 395     tc_uf_core lve tve (UfCoCon con tys as)
 396       = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 397         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ core_tys ->
 398         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 399         returnB_Tc (CoCon con_id core_tys core_atoms)
 400
 401     --  If a ccall, we have to patch in the types read from the pragma.
 402
 403     tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
 404       = ASSERT(null app_tys)
 405         mapB_Tc (tc_uf_type tve) arg_tys        `thenB_Tc` \ core_arg_tys ->
 406         tc_uf_type tve res_ty           `thenB_Tc` \ core_res_ty ->
 407         mapB_Tc (tc_uf_type tve) app_tys        `thenB_Tc` \ core_app_tys ->
 408         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 409         returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
 410                          core_app_tys core_atoms)
 411
 412     tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
 413       = mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ core_tys ->
 414         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 415         returnB_Tc (CoPrim op core_tys core_atoms)
 416
 417     tc_uf_core lve tve (UfCoLam binders body)
 418       = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
 419         let
 420             new_binders = map snd lve2
 421             new_lve     = lve2 `plusLVE` lve
 422         in
 423         tc_uf_core new_lve tve body      `thenB_Tc` \ new_body ->
 424         returnB_Tc (CoLam new_binders new_body)
 425
 426     tc_uf_core lve tve (UfCoTyLam tv body)
 427       = let
 428             (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
 429             new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
 430         in
 431         tc_uf_core lve new_tve body      `thenB_Tc` \ new_body ->
 432         returnB_Tc (CoTyLam new_tv new_body)
 433
 434     tc_uf_core lve tve (UfCoApp fun arg)
 435       = tc_uf_core lve tve fun  `thenB_Tc` \ new_fun ->
 436         tc_uf_atom lve tve arg  `thenB_Tc` \ new_arg ->
 437         returnB_Tc (CoApp new_fun new_arg)
 438
 439     tc_uf_core lve tve (UfCoTyApp expr ty)
 440       = tc_uf_core lve tve expr `thenB_Tc` \ new_expr ->
 441         tc_uf_type tve ty       `thenB_Tc` \ new_ty ->
 442         returnB_Tc (mkCoTyApp new_expr new_ty)
 443
 444     tc_uf_core lve tve (UfCoCase scrut alts)
 445       = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
 446         tc_alts alts             `thenB_Tc` \ new_alts ->
 447         returnB_Tc (CoCase new_scrut new_alts)
 448       where
 449         tc_alts (UfCoAlgAlts alts deflt)
 450           = mapB_Tc tc_alg_alt alts   `thenB_Tc` \ new_alts ->
 451             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 452             returnB_Tc (CoAlgAlts new_alts new_deflt)
 453           where
 454             tc_alg_alt (con, params, rhs)
 455               = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 456                 tc_uf_binders tve params        `thenB_Tc` \ lve2 ->
 457                 let
 458                     new_params = map snd lve2
 459                     new_lve    = lve2 `plusLVE` lve
 460                 in
 461                 tc_uf_core new_lve tve rhs      `thenB_Tc` \ new_rhs ->
 462                 returnB_Tc (con_id, new_params, new_rhs)
 463
 464         tc_alts (UfCoPrimAlts alts deflt)
 465           = mapB_Tc tc_prim_alt alts  `thenB_Tc` \ new_alts ->
 466             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 467             returnB_Tc (CoPrimAlts new_alts new_deflt)
 468           where
 469             tc_prim_alt (lit, rhs)
 470               = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 471                 returnB_Tc (lit, new_rhs)
 472
 473         tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
 474         tc_deflt (UfCoBindDefault b rhs)
 475           = tc_uf_binders tve [b]       `thenB_Tc` \ lve2 ->
 476             let
 477                 [new_b] = map snd lve2
 478                 new_lve = lve2 `plusLVE` lve
 479             in
 480             tc_uf_core new_lve tve rhs  `thenB_Tc` \ new_rhs ->
 481             returnB_Tc (CoBindDefault new_b new_rhs)
 482
 483     tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
 484       = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 485         tc_uf_binders tve [b]   `thenB_Tc` \ lve2 ->
 486         let
 487             [new_b] = map snd lve2
 488             new_lve = lve2 `plusLVE` lve
 489         in
 490         tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
 491         returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
 492
 493     tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
 494       = let
 495             (binders, rhss) = unzip pairs
 496         in
 497         tc_uf_binders tve binders   `thenB_Tc` \ lve2 ->
 498         let
 499             new_binders = map snd lve2
 500             new_lve     = lve2 `plusLVE` lve
 501         in
 502         mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
 503         tc_uf_core new_lve tve         body `thenB_Tc` \ new_body ->
 504         returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
 505
 506     tc_uf_core lve tve (UfCoSCC uf_cc body)
 507       = tc_uf_cc   uf_cc            `thenB_Tc` \ new_cc ->
 508         tc_uf_core lve tve body     `thenB_Tc` \ new_body ->
 509         returnB_Tc (CoSCC new_cc new_body)
 510       where
 511         tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
 512           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 513             returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
 514
 515         tc_uf_cc (UfDictCC id m g is_dupd is_caf)
 516           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 517             returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
 518
 519         tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
 520
 521         tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
 522         tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
 523
 524         --------
 525         adjust is_caf is_dupd cc
 526           = let
 527                 maybe_cafify = if is_caf  then cafifyCC else (\x->x)
 528                 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
 529             in
 530             maybe_dupify (maybe_cafify cc)
 531
 532     ---------------
 533     tc_uf_atom lve tve (UfCoLitAtom l)
 534       = returnB_Tc (CoLitAtom l)
 535
 536     tc_uf_atom lve tve (UfCoVarAtom v)
 537       = tc_uf_Id lve v                  `thenB_Tc` \ new_v ->
 538         returnB_Tc (CoVarAtom new_v)
 539
 540     ---------------
 541     tc_uf_binders tve ids_and_tys
 542       = let
 543             (ids, tys) = unzip ids_and_tys
 544         in
 545         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ new_tys ->
 546
 547         returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
 548
 549     ---------------
 550     -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
 551
 552     tc_uf_tyvar (Short u short_name)
 553       = let
 554             tyvar = mkUserTyVar u short_name
 555         in
 556         (tyvar, u, mkTyVarTy tyvar)
 557
 558     ---------------
 559     tc_uf_Id lve (BoringUfId v)
 560       = case (assocMaybe lve v) of
 561           Just xx -> returnB_Tc xx
 562           Nothing -> case (lookupE_ValueQuietly e v) of
 563                        Just xx -> returnB_Tc xx
 564                        Nothing -> --pprTrace "lookup_Quietly: " (ppr PprDebug v) (
 565                                   failB_Tc (panic "tc_uf_Id: no lookup")
 566                                   --)
 567                                   -- should be recover'd from
 568                                   -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
 569
 570     tc_uf_Id lve (SuperDictSelUfId c sc)
 571       = let
 572             clas       = lookupCE rec_ce c
 573             super_clas = lookupCE rec_ce sc
 574         in
 575         returnB_Tc (getSuperDictSelId clas super_clas)
 576
 577     tc_uf_Id lve (ClassOpUfId c op_name)
 578       = let
 579             clas = lookupCE rec_ce c
 580             op   = lookup_class_op clas op_name
 581         in
 582         returnB_Tc (getClassOpId clas op)
 583
 584     tc_uf_Id lve (DefaultMethodUfId c op_name)
 585       = let
 586             clas = lookupCE rec_ce c
 587             op   = lookup_class_op clas op_name
 588         in
 589         returnB_Tc (getDefaultMethodId clas op)
 590
 591     tc_uf_Id lve uf_id@(DictFunUfId c ty)
 592       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 593         let
 594             clas = lookupCE rec_ce c
 595             dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
 596                           Just id -> id
 597                           Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
 598                                         (ppr PprDebug (UfCoVar uf_id))
 599                                         -- The class and type are both
 600                                         -- visible, so the instance should
 601                                         -- jolly well be too!
 602         in
 603         returnB_Tc dfun_id
 604
 605     tc_uf_Id lve (ConstMethodUfId c op_name ty)
 606       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 607         let
 608             clas = lookupCE rec_ce c
 609             op   = lookup_class_op clas op_name
 610         in
 611         returnB_Tc (getConstMethodId clas op new_ty)
 612
 613     tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
 614       = tc_uf_Id lve unspec         `thenB_Tc` \ unspec_id ->
 615         mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
 616                                     `thenB_Tc` \ maybe_tys ->
 617         let
 618            spec_id = lookupSpecId unspec_id maybe_tys
 619         in
 620         returnB_Tc spec_id
 621
 622     tc_uf_Id lve (WorkerUfId unwrkr)
 623       = tc_uf_Id lve unwrkr     `thenB_Tc` \ unwrkr_id ->
 624         let
 625             strictness_info = getIdStrictness unwrkr_id
 626         in
 627         returnB_Tc (getWorkerId strictness_info)
 628
 629     ---------------
 630     lookup_class_op clas (ClassOpName _ _ _ tag)
 631       = getClassOps clas !! (tag - 1)
 632
 633     ---------------------------------------------------------------------
 634     tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
 635
 636     tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection[tcDataPragmas]{@data@ type pragmas}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 The purpose of a @data@ pragma is to convey data-constructor
 646 information that would otherwise be unknown.
 647
 648 It also records specialisation information which is added to each data
 649 constructor. This info just contains the type info for the
 650 specialisations which exist. No specialised Ids are actually created.
 651
 652 \begin{code}
 653 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
 654               -> RenamedDataPragmas
 655               -> Baby_TcM ([RenamedConDecl],    -- any pragma condecls
 656                            [SpecInfo])          -- specialisation info from pragmas
 657
 658 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
 659   = mapB_Tc do_one_spec specs           `thenB_Tc` \ spec_infos ->
 660     returnB_Tc (con_decls, spec_infos)
 661   where
 662     do_one_spec maybe_monotys
 663       = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
 664                                 `thenB_Tc` \ maybe_tys ->
 665         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 666
 667         checkB_Tc (length new_tyvars /= length maybe_tys)
 668                 (badSpecialisationErr "data" "wrong number of specialising types"
 669                                       (length new_tyvars) maybe_tys locn)
 670                                 `thenB_Tc_`
 671
 672         checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys)))
 673                 (badSpecialisationErr "data" "not all unboxed types"
 674                                       (length new_tyvars) maybe_tys locn)
 675                                 `thenB_Tc_`
 676
 677         returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
 678 \end{code}
 679
 680 %************************************************************************
 681 %*                                                                      *
 682 \subsection[tcTypePragmas]{@type@ synonym pragmas}
 683 %*                                                                      *
 684 %************************************************************************
 685
 686 The purpose of a @type@ pragma is to say that the synonym's
 687 representation should not be used by the user.
 688
 689 \begin{code}
 690 tcTypePragmas :: TypePragmas
 691               -> Bool           -- True <=> abstract synonym, please
 692
 693 tcTypePragmas NoTypePragmas     = False
 694 tcTypePragmas AbstractTySynonym = True
 695 \end{code}
 696