ghc/compiler/typecheck/TcPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   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     ) where
  15
  16 import TcMonad          hiding ( rnMtoTcM )
  17 import HsSyn            -- the stuff being typechecked
  18
  19 --import PrelInfo               ( PrimOp(..)    -- to see CCallOp
  20 --                      )
  21 import Type
  22 import CmdLineOpts
  23 import CostCentre
  24 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  25 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  26 import Id
  27 import IdInfo
  28 --import WwLib          ( mkWwBodies )
  29 import Maybes           ( assocMaybe, catMaybes )
  30 --import CoreLint               ( lintUnfolding )
  31 import TcMonoType       ( tcMonoType, tcPolyType )
  32 import Util
  33 import SrcLoc
  34 \end{code}
  35
  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@.
  39
  40 Of course, the pragmas also need to be checked.
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 \begin{code}
  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
  56
  57 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
  58   = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
  59
  60 tcClassOpPragmas e global_ty
  61                  rec_classop_id rec_defm_id
  62                  spec_infos
  63                  (ClassOpPragmas classop_pragmas defm_pragmas)
  64   = tcGenPragmas e
  65                  Nothing{-ty unknown-} rec_classop_id
  66                  classop_pragmas        `thenB_Tc` \ classop_idinfo ->
  67
  68     tcGenPragmas e
  69                  Nothing{-ty unknown-} rec_defm_id
  70                  defm_pragmas           `thenB_Tc` \ defm_idinfo ->
  71
  72     returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
  73 \end{code}
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
  78 %*                                                                      *
  79 %************************************************************************
  80
  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.
  84
  85 \begin{code}
  86 tcDictFunPragmas
  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
  92
  93 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
  94   = returnB_Tc noIdInfo
  95
  96 tcDictFunPragmas e dfun_ty final_dfun pragmas
  97   = let
  98         dfun_pragmas
  99           = case pragmas of
 100               SimpleInstancePragma      x   -> x
 101               ConstantInstancePragma    x _ -> x
 102               SpecialisedInstancePragma x _ -> x
 103     in
 104     tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
 105 \end{code}
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection[tcGenPragmas]{Basic pragmas about a value}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
 114 a problem, it just returns @noIdInfo@.
 115
 116 \begin{code}
 117 tcGenPragmas
 118         :: E                    -- lookup table
 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
 123
 124 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
 125   = returnB_Tc noIdInfo
 126
 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 (
 131
 132         -- OK, now we do the business
 133     let
 134         arity_info  = get_arity  arity_maybe
 135         upd_info    = get_upd    upd_maybe
 136     in
 137     tc_strictness e ty_maybe rec_final_id strictness
 138                                 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
 139
 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 ->
 145
 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 ->
 150
 151     returnB_Tc (
 152         noIdInfo
 153         `addInfo` arity_info
 154         `addInfo` upd_info
 155         `addInfo` def
 156
 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
 163
 164         `addInfo_UF` unfold_info
 165         `addInfo` spec_env
 166     ))
 167   where
 168     get_arity Nothing  = noInfo
 169     get_arity (Just a) = mkArityInfo a
 170
 171     get_upd Nothing  = noInfo
 172     get_upd (Just u) = (u :: UpdateInfo)
 173 \end{code}
 174
 175 Don't use the strictness info if a flag set.
 176 \begin{code}
 177 tc_strictness
 178         :: E
 179         -> Maybe Type
 180         -> Id           -- final Id (do not *touch*)
 181         -> ImpStrictness Name
 182         -> Baby_TcM (StrictnessInfo, Unfolding)
 183
 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)
 188     else
 189         do_strictness e ty_maybe rec_final_id info
 190 \end{code}
 191
 192 An easy one first:
 193 \begin{code}
 194 do_strictness e ty_maybe rec_final_id NoImpStrictness
 195   = returnB_Tc (noInfo, noInfo_UF)
 196 \end{code}
 197
 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:
 206
 207 \begin{code}
 208 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
 209   = let
 210         strictness_info
 211           = if is_bot
 212             then mkBottomStrictnessInfo
 213             else mkStrictnessInfo arg_info Nothing
 214     in
 215     returnB_Tc (strictness_info, noInfo_UF)
 216       -- no unfolding: the key --^^^^^^
 217 \end{code}
 218
 219 And, finally, the have-everthing, know-everything, do-everything
 220 ``normal case''.
 221 \begin{code}
 222 do_strictness e (Just wrapper_ty) rec_final_id
 223               (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
 224
 225   | is_bot -- it's a "bottoming Id"
 226   = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
 227
 228   | not (indicatesWorker wrap_arg_info)
 229   = -- No worker
 230     returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 231
 232   | otherwise
 233   = -- Strictness info suggests a worker.  Things could still
 234     -- go wrong if there's an abstract type involved, mind you.
 235     let
 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
 239                 -- losing laziness!!
 240     in
 241     getUniquesB_Tc (length tv_tmpls)    `thenB_Tc` \ tyvar_uniqs ->
 242     getUniquesB_Tc n_wrapper_args       `thenB_Tc` \ arg_uniqs ->
 243
 244     let
 245         (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
 246
 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
 250
 251         inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 252                                   (instantiateTy inst_env ret_ty)
 253
 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
 257     in
 258
 259     uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
 260                                                         `thenB_Tc` \ result ->
 261     case result of
 262
 263         Nothing ->      -- Alas, we met an abstract type
 264             returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 265
 266         Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 267
 268             let
 269                 worker_ty   = worker_ty_w_hole inst_ret_ty
 270             in
 271             getUniqueB_Tc `thenB_Tc` \ uniq ->
 272             fixB_Tc ( \ rec_wrkr_id ->
 273
 274                 tcGenPragmas e
 275                          (Just worker_ty)
 276                          rec_wrkr_id
 277                          wrkr_pragmas   `thenB_Tc` \ wrkr_id_info ->
 278
 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).
 284
 285             ) `thenB_Tc` \ worker_id ->
 286
 287             let
 288                 wrapper_rhs = wrapper_w_hole worker_id
 289                 n_tyvars    = length tyvars
 290                 arity       = length args
 291
 292             in
 293             returnB_Tc (
 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.
 297             )
 298 \end{code}
 299
 300 \begin{code}
 301 tc_specs :: E
 302          -> Id -- final Id for which these are specialisations (do not *touch*)
 303          -> Maybe Type
 304          -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
 305          -> Baby_TcM SpecEnv
 306
 307 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
 308   = returnB_Tc nullSpecEnv  -- ToDo: msg????????
 309
 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)
 313   where
 314     (main_tyvars, _) = splitForalls main_ty
 315
 316     rec_ce  = getE_CE  e
 317     rec_tce = getE_TCE e
 318
 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 ->
 324
 325         checkB_Tc (length main_tyvars /= length maybe_tys)
 326                 (badSpecialisationErr "value" "wrong number of specialising types"
 327                                       (length main_tyvars) maybe_tys locn)
 328                                 `thenB_Tc_`
 329         let
 330             spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
 331         in
 332         fixB_Tc ( \ rec_spec_id ->
 333
 334             tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
 335                 `thenB_Tc` \ spec_id_info ->
 336
 337             returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
 338
 339         ) `thenB_Tc` \ spec_id ->
 340
 341         returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
 342
 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)
 347 \end{code}
 348
 349 \begin{code}
 350 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
 351 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
 352
 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 ->
 356     let
 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 NoUnfolding when the unfolding is accessed
 363
 364         maybe_lint_expr = lintUnfolding locn core_expr
 365
 366         (lint_guidance, lint_expr) = case maybe_lint_expr of
 367           Just lint_expr -> (guidance, lint_expr)
 368           Nothing        -> (BadUnfolding, panic_expr)
 369     in
 370     returnB_Tc (mkUnfolding lint_guidance lint_expr)
 371   where
 372     rec_ce  = getE_CE  e
 373     rec_tce = getE_TCE e
 374
 375     panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
 376
 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
 381                -> Baby_TcM CoreExpr
 382
 383     tc_uf_core lve tve (UfVar v)
 384       = tc_uf_Id lve v          `thenB_Tc` \ id ->
 385         returnB_Tc (Var id)
 386
 387     tc_uf_core lve tve (UfLit l)
 388       = returnB_Tc (Lit l)
 389
 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)
 395
 396     --  If a ccall, we have to patch in the types read from the pragma.
 397
 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)
 406
 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)
 411
 412     tc_uf_core lve tve (UfLam binder body)
 413       = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
 414         let
 415             [new_binder] = map snd lve2
 416             new_lve     = lve2 `plusLVE` lve
 417         in
 418         tc_uf_core new_lve tve body      `thenB_Tc` \ new_body ->
 419         returnB_Tc (Lam new_binder new_body)
 420
 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)
 425
 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)
 430       where
 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)
 435           where
 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 ->
 439                 let
 440                     new_params = map snd lve2
 441                     new_lve    = lve2 `plusLVE` lve
 442                 in
 443                 tc_uf_core new_lve tve rhs      `thenB_Tc` \ new_rhs ->
 444                 returnB_Tc (con_id, new_params, new_rhs)
 445
 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)
 450           where
 451             tc_prim_alt (lit, rhs)
 452               = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 453                 returnB_Tc (lit, new_rhs)
 454
 455         tc_deflt UfCoNoDefault = returnB_Tc NoDefault
 456         tc_deflt (UfCoBindDefault b rhs)
 457           = tc_uf_binders tve [b]       `thenB_Tc` \ lve2 ->
 458             let
 459                 [new_b] = map snd lve2
 460                 new_lve = lve2 `plusLVE` lve
 461             in
 462             tc_uf_core new_lve tve rhs  `thenB_Tc` \ new_rhs ->
 463             returnB_Tc (BindDefault new_b new_rhs)
 464
 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 ->
 468         let
 469             [new_b] = map snd lve2
 470             new_lve = lve2 `plusLVE` lve
 471         in
 472         tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
 473         returnB_Tc (Let (NonRec new_b new_rhs) new_body)
 474
 475     tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
 476       = let
 477             (binders, rhss) = unzip pairs
 478         in
 479         tc_uf_binders tve binders   `thenB_Tc` \ lve2 ->
 480         let
 481             new_binders = map snd lve2
 482             new_lve     = lve2 `plusLVE` lve
 483         in
 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)
 487
 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)
 492       where
 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))
 496
 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))
 500
 501         tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
 502
 503         tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
 504         tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
 505
 506         --------
 507         adjust is_caf is_dupd cc
 508           = let
 509                 maybe_cafify = if is_caf  then cafifyCC else (\x->x)
 510                 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
 511             in
 512             maybe_dupify (maybe_cafify cc)
 513
 514     ---------------
 515     tc_uf_atom lve tve (UfCoLitAtom l)
 516       = returnB_Tc (LitArg l)
 517
 518     tc_uf_atom lve tve (UfCoVarAtom v)
 519       = tc_uf_Id lve v                  `thenB_Tc` \ new_v ->
 520         returnB_Tc (VarArg new_v)
 521
 522     ---------------
 523     tc_uf_binders tve ids_and_tys
 524       = let
 525             (ids, tys) = unzip ids_and_tys
 526         in
 527         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ new_tys ->
 528
 529         returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
 530
 531     ---------------
 532     -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
 533
 534     tc_uf_tyvar (Short u short_name)
 535       = let
 536             tyvar = mkUserTyVar u short_name
 537         in
 538         (tyvar, u, mkTyVarTy tyvar)
 539
 540     ---------------
 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:",
 548                                   --               ppr PprDebug v])
 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]
 552
 553     tc_uf_Id lve (SuperDictSelUfId c sc)
 554       = let
 555             clas       = lookupCE rec_ce c
 556             super_clas = lookupCE rec_ce sc
 557         in
 558         returnB_Tc (classSuperDictSelId clas super_clas)
 559
 560     tc_uf_Id lve (ClassOpUfId c op_name)
 561       = let
 562             clas = lookupCE rec_ce c
 563             op   = lookup_class_op clas op_name
 564         in
 565         returnB_Tc (classOpId clas op)
 566
 567     tc_uf_Id lve (DefaultMethodUfId c op_name)
 568       = let
 569             clas = lookupCE rec_ce c
 570             op   = lookup_class_op clas op_name
 571         in
 572         returnB_Tc (classDefaultMethodId clas op)
 573
 574     tc_uf_Id lve uf_id@(DictFunUfId c ty)
 575       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 576         let
 577             clas = lookupCE rec_ce c
 578             dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
 579                           Just id -> id
 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!
 585         in
 586         returnB_Tc dfun_id
 587
 588     tc_uf_Id lve (ConstMethodUfId c op_name ty)
 589       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 590         let
 591             clas = lookupCE rec_ce c
 592             op   = lookup_class_op clas op_name
 593         in
 594         returnB_Tc (getConstMethodId clas op new_ty)
 595
 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 ->
 600         let
 601            spec_id = lookupSpecId unspec_id maybe_tys
 602         in
 603         returnB_Tc spec_id
 604
 605     tc_uf_Id lve (WorkerUfId unwrkr)
 606       = tc_uf_Id lve unwrkr     `thenB_Tc` \ unwrkr_id ->
 607         let
 608             strictness_info = getIdStrictness unwrkr_id
 609         in
 610         if isLocallyDefined unwrkr_id
 611         then
 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 :-(
 614
 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
 620         else
 621             returnB_Tc (getWorkerId strictness_info)
 622
 623     ---------------
 624     lookup_class_op clas (ClassOpName _ _ _ tag)
 625       = classOps clas !! (tag - 1)
 626
 627     ---------------------------------------------------------------------
 628     tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
 629
 630     tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
 631 \end{code}
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsection[tcDataPragmas]{@data@ type pragmas}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 The purpose of a @data@ pragma is to convey data-constructor
 640 information that would otherwise be unknown.
 641
 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.
 645
 646 \begin{code}
 647 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
 648               -> RenamedDataPragmas
 649               -> Baby_TcM ([RenamedConDecl],    -- any pragma condecls
 650                            [SpecInfo])          -- specialisation info from pragmas
 651
 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)
 655   where
 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 ->
 660
 661         checkB_Tc (length new_tyvars /= length maybe_tys)
 662                 (badSpecialisationErr "data" "wrong number of specialising types"
 663                                       (length new_tyvars) maybe_tys locn)
 664                                 `thenB_Tc_`
 665
 666         checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
 667                 (badSpecialisationErr "data" "not all unboxed types"
 668                                       (length new_tyvars) maybe_tys locn)
 669                                 `thenB_Tc_`
 670
 671         returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
 672 \end{code}