compiler/iface/TcIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
   5
   6 \begin{code}
   7 module TcIface (
   8         tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
   9         tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal,
  10         tcExtCoreBindings
  11  ) where
  12
  13 #include "HsVersions.h"
  14
  15 import IfaceSyn
  16 import LoadIface        ( loadInterface, loadWiredInHomeIface,
  17                           loadDecls, findAndReadIface )
  18 import IfaceEnv         ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
  19                           extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
  20                           tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc,
  21                           newIfaceName, newIfaceNames, ifaceExportNames )
  22 import BuildTyCl        ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
  23                           mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
  24 import TcRnMonad
  25 import Type             ( liftedTypeKind, splitTyConApp, mkTyConApp,
  26                           liftedTypeKindTyCon, unliftedTypeKindTyCon,
  27                           openTypeKindTyCon, argTypeKindTyCon,
  28                           ubxTupleKindTyCon,
  29                           mkTyVarTys, ThetaType )
  30 import TypeRep          ( Type(..), PredType(..) )
  31 import TyCon            ( TyCon, tyConName )
  32 import HscTypes         ( ExternalPackageState(..),
  33                           TyThing(..), tyThingClass, tyThingTyCon,
  34                           ModIface(..), ModDetails(..), HomeModInfo(..),
  35                           emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
  36 import InstEnv          ( Instance(..), mkImportedInstance )
  37 import CoreSyn
  38 import CoreUtils        ( exprType, dataConRepFSInstPat )
  39 import CoreUnfold
  40 import CoreLint         ( lintUnfolding )
  41 import WorkWrap         ( mkWrapper )
  42 import Id               ( Id, mkVanillaGlobal, mkLocalId )
  43 import MkId             ( mkFCallId )
  44 import IdInfo           ( IdInfo, CafInfo(..), WorkerInfo(..),
  45                           setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
  46                           setArityInfo, setInlinePragInfo, setCafInfo,
  47                           vanillaIdInfo, newStrictnessInfo )
  48 import Class            ( Class )
  49 import TyCon            ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
  50 import DataCon          ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys )
  51 import TysWiredIn       ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
  52 import Var              ( TyVar, mkTyVar, tyVarKind )
  53 import Name             ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
  54                           nameOccName, wiredInNameTyThing_maybe )
  55 import NameEnv
  56 import OccName          ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace,
  57                           pprNameSpace, occNameFS  )
  58 import FastString       ( FastString )
  59 import Module           ( Module, moduleName )
  60 import UniqFM           ( lookupUFM )
  61 import UniqSupply       ( initUs_, uniqsFromSupply )
  62 import Outputable
  63 import ErrUtils         ( Message )
  64 import Maybes           ( MaybeErr(..) )
  65 import SrcLoc           ( noSrcLoc )
  66 import Util             ( zipWithEqual, equalLength, splitAtList )
  67 import DynFlags         ( DynFlag(..), isOneShot )
  68
  69 \end{code}
  70
  71 This module takes
  72
  73         IfaceDecl -> TyThing
  74         IfaceType -> Type
  75         etc
  76
  77 An IfaceDecl is populated with RdrNames, and these are not renamed to
  78 Names before typechecking, because there should be no scope errors etc.
  79
  80         -- For (b) consider: f = $(...h....)
  81         -- where h is imported, and calls f via an hi-boot file.
  82         -- This is bad!  But it is not seen as a staging error, because h
  83         -- is indeed imported.  We don't want the type-checker to black-hole
  84         -- when simplifying and compiling the splice!
  85         --
  86         -- Simple solution: discard any unfolding that mentions a variable
  87         -- bound in this module (and hence not yet processed).
  88         -- The discarding happens when forkM finds a type error.
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 %*      tcImportDecl is the key function for "faulting in"              *
  93 %*      imported things
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 The main idea is this.  We are chugging along type-checking source code, and
  98 find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
  99 it in the EPS type envt.  So it
 100         1 loads GHC.Base.hi
 101         2 gets the decl for GHC.Base.map
 102         3 typechecks it via tcIfaceDecl
 103         4 and adds it to the type env in the EPS
 104
 105 Note that DURING STEP 4, we may find that map's type mentions a type
 106 constructor that also
 107
 108 Notice that for imported things we read the current version from the EPS
 109 mutable variable.  This is important in situations like
 110         ...$(e1)...$(e2)...
 111 where the code that e1 expands to might import some defns that
 112 also turn out to be needed by the code that e2 expands to.
 113
 114 \begin{code}
 115 tcImportDecl :: Name -> TcM TyThing
 116 -- Entry point for *source-code* uses of importDecl
 117 tcImportDecl name
 118   | Just thing <- wiredInNameTyThing_maybe name
 119   = do  { initIfaceTcRn (loadWiredInHomeIface name)
 120         ; return thing }
 121   | otherwise
 122   = do  { traceIf (text "tcImportDecl" <+> ppr name)
 123         ; mb_thing <- initIfaceTcRn (importDecl name)
 124         ; case mb_thing of
 125             Succeeded thing -> return thing
 126             Failed err      -> failWithTc err }
 127
 128 checkWiredInTyCon :: TyCon -> TcM ()
 129 -- Ensure that the home module of the TyCon (and hence its instances)
 130 -- are loaded. It might not be a wired-in tycon (see the calls in TcUnify),
 131 -- in which case this is a no-op.
 132 checkWiredInTyCon tc
 133   | not (isWiredInName tc_name)
 134   = return ()
 135   | otherwise
 136   = do  { mod <- getModule
 137         ; if nameIsLocalOrFrom mod tc_name then
 138                 -- Don't look for (non-existent) Float.hi when
 139                 -- compiling Float.lhs, which mentions Float of course
 140                 return ()
 141           else  -- A bit yukky to call initIfaceTcRn here
 142                 initIfaceTcRn (loadWiredInHomeIface tc_name)
 143         }
 144   where
 145     tc_name = tyConName tc
 146
 147 importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
 148 -- Get the TyThing for this Name from an interface file
 149 -- It's not a wired-in thing -- the caller caught that
 150 importDecl name
 151   = ASSERT( not (isWiredInName name) )
 152     do  { traceIf nd_doc
 153
 154         -- Load the interface, which should populate the PTE
 155         ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
 156         ; case mb_iface of {
 157                 Failed err_msg  -> return (Failed err_msg) ;
 158                 Succeeded iface -> do
 159
 160         -- Now look it up again; this time we should find it
 161         { eps <- getEps
 162         ; case lookupTypeEnv (eps_PTE eps) name of
 163             Just thing -> return (Succeeded thing)
 164             Nothing    -> return (Failed not_found_msg)
 165     }}}
 166   where
 167     nd_doc = ptext SLIT("Need decl for") <+> ppr name
 168     not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+>
 169                                 pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
 170                        2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
 171                                 ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176                 Type-checking a complete interface
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 Suppose we discover we don't need to recompile.  Then we must type
 181 check the old interface file.  This is a bit different to the
 182 incremental type checking we do as we suck in interface files.  Instead
 183 we do things similarly as when we are typechecking source decls: we
 184 bring into scope the type envt for the interface all at once, using a
 185 knot.  Remember, the decls aren't necessarily in dependency order --
 186 and even if they were, the type decls might be mutually recursive.
 187
 188 \begin{code}
 189 typecheckIface :: ModIface      -- Get the decls from here
 190                -> TcRnIf gbl lcl ModDetails
 191 typecheckIface iface
 192   = initIfaceTc iface $ \ tc_env_var -> do
 193         -- The tc_env_var is freshly allocated, private to
 194         -- type-checking this particular interface
 195         {       -- Get the right set of decls and rules.  If we are compiling without -O
 196                 -- we discard pragmas before typechecking, so that we don't "see"
 197                 -- information that we shouldn't.  From a versioning point of view
 198                 -- It's not actually *wrong* to do so, but in fact GHCi is unable
 199                 -- to handle unboxed tuples, so it must not see unfoldings.
 200           ignore_prags <- doptM Opt_IgnoreInterfacePragmas
 201
 202                 -- Load & typecheck the decls
 203         ; decl_things <- loadDecls ignore_prags (mi_decls iface)
 204
 205         ; let type_env = mkNameEnv decl_things
 206         ; writeMutVar tc_env_var type_env
 207
 208                 -- Now do those rules and instances
 209         ; let { rules | ignore_prags = []
 210                       | otherwise    = mi_rules iface
 211               ; dfuns = mi_insts iface
 212               }
 213         ; dfuns <- mapM tcIfaceInst dfuns
 214         ; rules <- mapM tcIfaceRule rules
 215
 216                 -- Exports
 217         ; exports <-  ifaceExportNames (mi_exports iface)
 218
 219                 -- Finished
 220         ; return (ModDetails {  md_types = type_env,
 221                                 md_insts = dfuns,
 222                                 md_rules = rules,
 223                                 md_exports = exports })
 224     }
 225 \end{code}
 226
 227
 228 %************************************************************************
 229 %*                                                                      *
 230                 Type and class declarations
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 \begin{code}
 235 tcHiBootIface :: Module -> TcRn ModDetails
 236 -- Load the hi-boot iface for the module being compiled,
 237 -- if it indeed exists in the transitive closure of imports
 238 -- Return the ModDetails, empty if no hi-boot iface
 239 tcHiBootIface mod
 240   = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
 241
 242         ; mode <- getGhcMode
 243         ; if not (isOneShot mode)
 244                 -- In --make and interactive mode, if this module has an hs-boot file
 245                 -- we'll have compiled it already, and it'll be in the HPT
 246                 --
 247                 -- We check wheher the interface is a *boot* interface.
 248                 -- It can happen (when using GHC from Visual Studio) that we
 249                 -- compile a module in TypecheckOnly mode, with a stable,
 250                 -- fully-populated HPT.  In that case the boot interface isn't there
 251                 -- (it's been replaced by the mother module) so we can't check it.
 252                 -- And that's fine, because if M's ModInfo is in the HPT, then
 253                 -- it's been compiled once, and we don't need to check the boot iface
 254           then do { hpt <- getHpt
 255                   ; case lookupUFM hpt (moduleName mod) of
 256                       Just info | mi_boot (hm_iface info)
 257                                 -> return (hm_details info)
 258                       other -> return emptyModDetails }
 259           else do
 260
 261         -- OK, so we're in one-shot mode.
 262         -- In that case, we're read all the direct imports by now,
 263         -- so eps_is_boot will record if any of our imports mention us by
 264         -- way of hi-boot file
 265         { eps <- getEps
 266         ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
 267             Nothing -> return emptyModDetails ; -- The typical case
 268
 269             Just (_, False) -> failWithTc moduleLoop ;
 270                 -- Someone below us imported us!
 271                 -- This is a loop with no hi-boot in the way
 272
 273             Just (_mod, True) ->        -- There's a hi-boot interface below us
 274
 275     do  { read_result <- findAndReadIface
 276                                 need mod
 277                                 True    -- Hi-boot file
 278
 279         ; case read_result of
 280                 Failed err               -> failWithTc (elaborate err)
 281                 Succeeded (iface, _path) -> typecheckIface iface
 282     }}}}
 283   where
 284     need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
 285                  <+> ptext SLIT("to compare against the Real Thing")
 286
 287     moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
 288                      <+> ptext SLIT("depends on itself")
 289
 290     elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+>
 291                           quotes (ppr mod) <> colon) 4 err
 292 \end{code}
 293
 294
 295 %************************************************************************
 296 %*                                                                      *
 297                 Type and class declarations
 298 %*                                                                      *
 299 %************************************************************************
 300
 301 When typechecking a data type decl, we *lazily* (via forkM) typecheck
 302 the constructor argument types.  This is in the hope that we may never
 303 poke on those argument types, and hence may never need to load the
 304 interface files for types mentioned in the arg types.
 305
 306 E.g.
 307         data Foo.S = MkS Baz.T
 308 Mabye we can get away without even loading the interface for Baz!
 309
 310 This is not just a performance thing.  Suppose we have
 311         data Foo.S = MkS Baz.T
 312         data Baz.T = MkT Foo.S
 313 (in different interface files, of course).
 314 Now, first we load and typecheck Foo.S, and add it to the type envt.
 315 If we do explore MkS's argument, we'll load and typecheck Baz.T.
 316 If we explore MkT's argument we'll find Foo.S already in the envt.
 317
 318 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
 319 typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
 320 which isn't done yet.
 321
 322 All very cunning. However, there is a rather subtle gotcha which bit
 323 me when developing this stuff.  When we typecheck the decl for S, we
 324 extend the type envt with S, MkS, and all its implicit Ids.  Suppose
 325 (a bug, but it happened) that the list of implicit Ids depended in
 326 turn on the constructor arg types.  Then the following sequence of
 327 events takes place:
 328         * we build a thunk <t> for the constructor arg tys
 329         * we build a thunk for the extended type environment (depends on <t>)
 330         * we write the extended type envt into the global EPS mutvar
 331
 332 Now we look something up in the type envt
 333         * that pulls on <t>
 334         * which reads the global type envt out of the global EPS mutvar
 335         * but that depends in turn on <t>
 336
 337 It's subtle, because, it'd work fine if we typechecked the constructor args
 338 eagerly -- they don't need the extended type envt.  They just get the extended
 339 type envt by accident, because they look at it later.
 340
 341 What this means is that the implicitTyThings MUST NOT DEPEND on any of
 342 the forkM stuff.
 343
 344
 345 \begin{code}
 346 tcIfaceDecl :: IfaceDecl -> IfL TyThing
 347
 348 tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
 349   = do  { name <- lookupIfaceTop occ_name
 350         ; ty <- tcIfaceType iface_type
 351         ; info <- tcIdInfo name ty info
 352         ; return (AnId (mkVanillaGlobal name ty info)) }
 353
 354 tcIfaceDecl (IfaceData {ifName = occ_name,
 355                         ifTyVars = tv_bndrs,
 356                         ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
 357                         ifCons = rdr_cons,
 358                         ifRec = is_rec,
 359                         ifGeneric = want_generic })
 360   = do  { tc_name <- lookupIfaceTop occ_name
 361         ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 362
 363         { tycon <- fixM ( \ tycon -> do
 364             { stupid_theta <- tcIfaceCtxt ctxt
 365             ; cons  <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
 366             ; buildAlgTyCon tc_name tyvars stupid_theta
 367                             cons is_rec want_generic gadt_syn
 368             })
 369         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
 370         ; return (ATyCon tycon)
 371     }}
 372
 373 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
 374                        ifSynRhs = rdr_rhs_ty})
 375    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 376      { tc_name <- lookupIfaceTop occ_name
 377      ; rhs_ty <- tcIfaceType rdr_rhs_ty
 378      ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
 379      }
 380
 381 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
 382                          ifFDs = rdr_fds, ifSigs = rdr_sigs,
 383                          ifRec = tc_isrec })
 384 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 385 --       as we do abstract tycons
 386   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 387     { cls_name <- lookupIfaceTop occ_name
 388     ; ctxt <- tcIfaceCtxt rdr_ctxt
 389     ; sigs <- mappM tc_sig rdr_sigs
 390     ; fds  <- mappM tc_fd rdr_fds
 391     ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
 392     ; return (AClass cls) }
 393   where
 394    tc_sig (IfaceClassOp occ dm rdr_ty)
 395      = do { op_name <- lookupIfaceTop occ
 396           ; op_ty   <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
 397                 -- Must be done lazily for just the same reason as the
 398                 -- context of a data decl: the type sig might mention the
 399                 -- class being defined
 400           ; return (op_name, dm, op_ty) }
 401
 402    mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
 403
 404    tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
 405                            ; tvs2' <- mappM tcIfaceTyVar tvs2
 406                            ; return (tvs1', tvs2') }
 407
 408 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 409   = do  { name <- lookupIfaceTop rdr_name
 410         ; return (ATyCon (mkForeignTyCon name ext_name
 411                                          liftedTypeKind 0)) }
 412
 413 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
 414   = case if_cons of
 415         IfAbstractTyCon  -> return mkAbstractTyConRhs
 416         IfDataTyCon cons -> do  { data_cons <- mappM tc_con_decl cons
 417                                 ; return (mkDataTyConRhs data_cons) }
 418         IfNewTyCon con   -> do  { data_con <- tc_con_decl con
 419                                 ; mkNewTyConRhs tycon_name tycon data_con }
 420   where
 421     tc_con_decl (IfCon { ifConInfix = is_infix,
 422                          ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
 423                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
 424                          ifConArgTys = args, ifConFields = field_lbls,
 425                          ifConStricts = stricts})
 426       = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
 427         bindIfaceTyVars ex_tvs   $ \ ex_tyvars -> do
 428         { name  <- lookupIfaceTop occ
 429         ; eq_spec <- tcIfaceEqSpec spec
 430         ; theta <- tcIfaceCtxt ctxt     -- Laziness seems not worth the bother here
 431                 -- At one stage I thought that this context checking *had*
 432                 -- to be lazy, because of possible mutual recursion between the
 433                 -- type and the classe:
 434                 -- E.g.
 435                 --      class Real a where { toRat :: a -> Ratio Integer }
 436                 --      data (Real a) => Ratio a = ...
 437                 -- But now I think that the laziness in checking class ops breaks
 438                 -- the loop, so no laziness needed
 439
 440         -- Read the argument types, but lazily to avoid faulting in
 441         -- the component types unless they are really needed
 442         ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
 443         ; lbl_names <- mappM lookupIfaceTop field_lbls
 444
 445         ; buildDataCon name is_infix {- Not infix -}
 446                        stricts lbl_names
 447                        univ_tyvars ex_tyvars
 448                        eq_spec theta
 449                        arg_tys tycon
 450         }
 451     mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
 452
 453 tcIfaceEqSpec spec
 454   = mapM do_item spec
 455   where
 456     do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
 457                               ; ty <- tcIfaceType if_ty
 458                               ; return (tv,ty) }
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464                 Instances
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 \begin{code}
 469 tcIfaceInst :: IfaceInst -> IfL Instance
 470 tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
 471                          ifInstCls = cls, ifInstTys = mb_tcs,
 472                          ifInstOrph = orph })
 473   = do  { dfun    <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
 474                      tcIfaceExtId (LocalTop dfun_occ)
 475         ; cls'    <- lookupIfaceExt cls
 476         ; mb_tcs' <- mapM do_tc mb_tcs
 477         ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) }
 478   where
 479     do_tc Nothing   = return Nothing
 480     do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
 481 \end{code}
 482
 483
 484 %************************************************************************
 485 %*                                                                      *
 486                 Rules
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
 491 are in the type environment.  However, remember that typechecking a Rule may
 492 (as a side effect) augment the type envt, and so we may need to iterate the process.
 493
 494 \begin{code}
 495 tcIfaceRule :: IfaceRule -> IfL CoreRule
 496 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 497                         ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
 498                         ifRuleOrph = orph })
 499   = do  { fn' <- lookupIfaceExt fn
 500         ; ~(bndrs', args', rhs') <-
 501                 -- Typecheck the payload lazily, in the hope it'll never be looked at
 502                 forkM (ptext SLIT("Rule") <+> ftext name) $
 503                 bindIfaceBndrs bndrs                      $ \ bndrs' ->
 504                 do { args' <- mappM tcIfaceExpr args
 505                    ; rhs'  <- tcIfaceExpr rhs
 506                    ; return (bndrs', args', rhs') }
 507         ; mb_tcs <- mapM ifTopFreeName args
 508         ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act,
 509                           ru_bndrs = bndrs', ru_args = args',
 510                           ru_rhs = rhs', ru_orph = orph,
 511                           ru_rough = mb_tcs,
 512                           ru_local = isLocalIfaceExtName fn }) }
 513   where
 514         -- This function *must* mirror exactly what Rules.topFreeName does
 515         -- We could have stored the ru_rough field in the iface file
 516         -- but that would be redundant, I think.
 517         -- The only wrinkle is that we must not be deceived by
 518         -- type syononyms at the top of a type arg.  Since
 519         -- we can't tell at this point, we are careful not
 520         -- to write them out in coreRuleToIfaceRule
 521     ifTopFreeName :: IfaceExpr -> IfL (Maybe Name)
 522     ifTopFreeName (IfaceType (IfaceTyConApp tc _ ))
 523         = do { n <- lookupIfaceTc tc
 524              ; return (Just n) }
 525     ifTopFreeName (IfaceApp f a) = ifTopFreeName f
 526     ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext
 527                                       ; return (Just n) }
 528     ifTopFreeName other = return Nothing
 529 \end{code}
 530
 531
 532 %************************************************************************
 533 %*                                                                      *
 534                         Types
 535 %*                                                                      *
 536 %************************************************************************
 537
 538 \begin{code}
 539 tcIfaceType :: IfaceType -> IfL Type
 540 tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
 541 tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
 542 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 543 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 544 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
 545 tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
 546
 547 tcIfaceTypes tys = mapM tcIfaceType tys
 548
 549 -----------------------------------------
 550 tcIfacePredType :: IfacePredType -> IfL PredType
 551 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
 552 tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
 553 tcIfacePredType (IfaceEqPred t1 t2)  = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
 554
 555 -----------------------------------------
 556 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
 557 tcIfaceCtxt sts = mappM tcIfacePredType sts
 558 \end{code}
 559
 560
 561 %************************************************************************
 562 %*                                                                      *
 563                         Core
 564 %*                                                                      *
 565 %************************************************************************
 566
 567 \begin{code}
 568 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
 569 tcIfaceExpr (IfaceType ty)
 570   = tcIfaceType ty              `thenM` \ ty' ->
 571     returnM (Type ty')
 572
 573 tcIfaceExpr (IfaceLcl name)
 574   = tcIfaceLclId name   `thenM` \ id ->
 575     returnM (Var id)
 576
 577 tcIfaceExpr (IfaceExt gbl)
 578   = tcIfaceExtId gbl    `thenM` \ id ->
 579     returnM (Var id)
 580
 581 tcIfaceExpr (IfaceLit lit)
 582   = returnM (Lit lit)
 583
 584 tcIfaceExpr (IfaceFCall cc ty)
 585   = tcIfaceType ty      `thenM` \ ty' ->
 586     newUnique           `thenM` \ u ->
 587     returnM (Var (mkFCallId u cc ty'))
 588
 589 tcIfaceExpr (IfaceTuple boxity args)
 590   = mappM tcIfaceExpr args      `thenM` \ args' ->
 591     let
 592         -- Put the missing type arguments back in
 593         con_args = map (Type . exprType) args' ++ args'
 594     in
 595     returnM (mkApps (Var con_id) con_args)
 596   where
 597     arity = length args
 598     con_id = dataConWorkId (tupleCon boxity arity)
 599
 600
 601 tcIfaceExpr (IfaceLam bndr body)
 602   = bindIfaceBndr bndr          $ \ bndr' ->
 603     tcIfaceExpr body            `thenM` \ body' ->
 604     returnM (Lam bndr' body')
 605
 606 tcIfaceExpr (IfaceApp fun arg)
 607   = tcIfaceExpr fun             `thenM` \ fun' ->
 608     tcIfaceExpr arg             `thenM` \ arg' ->
 609     returnM (App fun' arg')
 610
 611 tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
 612   = tcIfaceExpr scrut           `thenM` \ scrut' ->
 613     newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name ->
 614     let
 615         scrut_ty   = exprType scrut'
 616         case_bndr' = mkLocalId case_bndr_name scrut_ty
 617         tc_app     = splitTyConApp scrut_ty
 618                 -- NB: Won't always succeed (polymoprhic case)
 619                 --     but won't be demanded in those cases
 620                 -- NB: not tcSplitTyConApp; we are looking at Core here
 621                 --     look through non-rec newtypes to find the tycon that
 622                 --     corresponds to the datacon in this case alternative
 623     in
 624     extendIfaceIdEnv [case_bndr']       $
 625     mappM (tcIfaceAlt tc_app) alts      `thenM` \ alts' ->
 626     tcIfaceType ty              `thenM` \ ty' ->
 627     returnM (Case scrut' case_bndr' ty' alts')
 628
 629 tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
 630   = tcIfaceExpr rhs             `thenM` \ rhs' ->
 631     bindIfaceId bndr            $ \ bndr' ->
 632     tcIfaceExpr body            `thenM` \ body' ->
 633     returnM (Let (NonRec bndr' rhs') body')
 634
 635 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
 636   = bindIfaceIds bndrs          $ \ bndrs' ->
 637     mappM tcIfaceExpr rhss      `thenM` \ rhss' ->
 638     tcIfaceExpr body            `thenM` \ body' ->
 639     returnM (Let (Rec (bndrs' `zip` rhss')) body')
 640   where
 641     (bndrs, rhss) = unzip pairs
 642
 643 tcIfaceExpr (IfaceCast expr co) = do
 644   expr' <- tcIfaceExpr expr
 645   co' <- tcIfaceType co
 646   returnM (Cast expr' co')
 647
 648 tcIfaceExpr (IfaceNote note expr)
 649   = tcIfaceExpr expr            `thenM` \ expr' ->
 650     case note of
 651         IfaceInlineMe     -> returnM (Note InlineMe   expr')
 652         IfaceSCC cc       -> returnM (Note (SCC cc)   expr')
 653         IfaceCoreNote n   -> returnM (Note (CoreNote n) expr')
 654
 655 -------------------------
 656 tcIfaceAlt _ (IfaceDefault, names, rhs)
 657   = ASSERT( null names )
 658     tcIfaceExpr rhs             `thenM` \ rhs' ->
 659     returnM (DEFAULT, [], rhs')
 660
 661 tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
 662   = ASSERT( null names )
 663     tcIfaceExpr rhs             `thenM` \ rhs' ->
 664     returnM (LitAlt lit, [], rhs')
 665
 666 -- A case alternative is made quite a bit more complicated
 667 -- by the fact that we omit type annotations because we can
 668 -- work them out.  True enough, but its not that easy!
 669 tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
 670   = do  { let tycon_mod = nameModule (tyConName tycon)
 671         ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
 672         ; ASSERT2( con `elem` tyConDataCons tycon,
 673                    ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
 674           tcIfaceDataAlt con inst_tys arg_strs rhs }
 675
 676 tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
 677   = ASSERT( isTupleTyCon tycon )
 678     do  { let [data_con] = tyConDataCons tycon
 679         ; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
 680
 681 tcIfaceDataAlt con inst_tys arg_strs rhs
 682   = do  { us <- newUniqueSupply
 683         ; let uniqs = uniqsFromSupply us
 684         ; let (ex_tvs, co_tvs, arg_ids)
 685                       = dataConRepFSInstPat arg_strs uniqs con inst_tys
 686               all_tvs = ex_tvs ++ co_tvs
 687
 688         ; rhs' <- extendIfaceTyVarEnv all_tvs   $
 689                   extendIfaceIdEnv arg_ids      $
 690                   tcIfaceExpr rhs
 691         ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
 692 \end{code}
 693
 694
 695 \begin{code}
 696 tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind]   -- Used for external core
 697 tcExtCoreBindings []     = return []
 698 tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
 699
 700 do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
 701 do_one (IfaceNonRec bndr rhs) thing_inside
 702   = do  { rhs' <- tcIfaceExpr rhs
 703         ; bndr' <- newExtCoreBndr bndr
 704         ; extendIfaceIdEnv [bndr'] $ do
 705         { core_binds <- thing_inside
 706         ; return (NonRec bndr' rhs' : core_binds) }}
 707
 708 do_one (IfaceRec pairs) thing_inside
 709   = do  { bndrs' <- mappM newExtCoreBndr bndrs
 710         ; extendIfaceIdEnv bndrs' $ do
 711         { rhss' <- mappM tcIfaceExpr rhss
 712         ; core_binds <- thing_inside
 713         ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
 714   where
 715     (bndrs,rhss) = unzip pairs
 716 \end{code}
 717
 718
 719 %************************************************************************
 720 %*                                                                      *
 721                 IdInfo
 722 %*                                                                      *
 723 %************************************************************************
 724
 725 \begin{code}
 726 tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
 727 tcIdInfo name ty NoInfo         = return vanillaIdInfo
 728 tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
 729   where
 730     -- Set the CgInfo to something sensible but uninformative before
 731     -- we start; default assumption is that it has CAFs
 732     init_info = vanillaIdInfo
 733
 734     tcPrag info HsNoCafRefs         = returnM (info `setCafInfo`   NoCafRefs)
 735     tcPrag info (HsArity arity)     = returnM (info `setArityInfo` arity)
 736     tcPrag info (HsStrictness str)  = returnM (info `setAllStrictnessInfo` Just str)
 737
 738         -- The next two are lazy, so they don't transitively suck stuff in
 739     tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
 740     tcPrag info (HsInline inline_prag) = returnM (info `setInlinePragInfo` inline_prag)
 741     tcPrag info (HsUnfold expr)
 742         = tcPragExpr name expr  `thenM` \ maybe_expr' ->
 743           let
 744                 -- maybe_expr' doesn't get looked at if the unfolding
 745                 -- is never inspected; so the typecheck doesn't even happen
 746                 unfold_info = case maybe_expr' of
 747                                 Nothing    -> noUnfolding
 748                                 Just expr' -> mkTopUnfolding expr'
 749           in
 750           returnM (info `setUnfoldingInfoLazily` unfold_info)
 751 \end{code}
 752
 753 \begin{code}
 754 tcWorkerInfo ty info wkr arity
 755   = do  { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
 756
 757         -- We return without testing maybe_wkr_id, but as soon as info is
 758         -- looked at we will test it.  That's ok, because its outside the
 759         -- knot; and there seems no big reason to further defer the
 760         -- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
 761         -- over the unfolding until it's actually used does seem worth while.)
 762         ; us <- newUniqueSupply
 763
 764         ; returnM (case mb_wkr_id of
 765                      Nothing     -> info
 766                      Just wkr_id -> add_wkr_info us wkr_id info) }
 767   where
 768     doc = text "Worker for" <+> ppr wkr
 769     add_wkr_info us wkr_id info
 770         = info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
 771                `setWorkerInfo`           HasWorker wkr_id arity
 772
 773     mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
 774
 775         -- We are relying here on strictness info always appearing
 776         -- before worker info,  fingers crossed ....
 777     strict_sig = case newStrictnessInfo info of
 778                    Just sig -> sig
 779                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
 780 \end{code}
 781
 782 For unfoldings we try to do the job lazily, so that we never type check
 783 an unfolding that isn't going to be looked at.
 784
 785 \begin{code}
 786 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
 787 tcPragExpr name expr
 788   = forkM_maybe doc $
 789     tcIfaceExpr expr            `thenM` \ core_expr' ->
 790
 791                 -- Check for type consistency in the unfolding
 792     ifOptM Opt_DoCoreLinting (
 793         get_in_scope_ids                        `thenM` \ in_scope ->
 794         case lintUnfolding noSrcLoc in_scope core_expr' of
 795           Nothing       -> returnM ()
 796           Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
 797     )                           `thenM_`
 798
 799    returnM core_expr'
 800   where
 801     doc = text "Unfolding of" <+> ppr name
 802     get_in_scope_ids    -- Urgh; but just for linting
 803         = setLclEnv () $
 804           do    { env <- getGblEnv
 805                 ; case if_rec_types env of {
 806                           Nothing -> return [] ;
 807                           Just (_, get_env) -> do
 808                 { type_env <- get_env
 809                 ; return (typeEnvIds type_env) }}}
 810 \end{code}
 811
 812
 813
 814 %************************************************************************
 815 %*                                                                      *
 816                 Getting from Names to TyThings
 817 %*                                                                      *
 818 %************************************************************************
 819
 820 \begin{code}
 821 tcIfaceGlobal :: Name -> IfL TyThing
 822 tcIfaceGlobal name
 823   | Just thing <- wiredInNameTyThing_maybe name
 824         -- Wired-in things include TyCons, DataCons, and Ids
 825   = do { loadWiredInHomeIface name; return thing }
 826         -- Even though we are in an interface file, we want to make
 827         -- sure its instances are loaded (imagine f :: Double -> Double)
 828         -- and its RULES are loaded too
 829   | otherwise
 830   = do  { (eps,hpt) <- getEpsAndHpt
 831         ; dflags <- getDOpts
 832         ; case lookupType dflags hpt (eps_PTE eps) name of {
 833             Just thing -> return thing ;
 834             Nothing    -> do
 835
 836         { env <- getGblEnv
 837         ; case if_rec_types env of {
 838             Just (mod, get_type_env)
 839                 | nameIsLocalOrFrom mod name
 840                 -> do           -- It's defined in the module being compiled
 841                 { type_env <- setLclEnv () get_type_env         -- yuk
 842                 ; case lookupNameEnv type_env name of
 843                         Just thing -> return thing
 844                         Nothing    -> pprPanic "tcIfaceGlobal (local): not found:"
 845                                                 (ppr name $$ ppr type_env) }
 846
 847           ; other -> do
 848
 849         { mb_thing <- importDecl name   -- It's imported; go get it
 850         ; case mb_thing of
 851             Failed err      -> failIfM err
 852             Succeeded thing -> return thing
 853     }}}}}
 854
 855 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
 856 tcIfaceTyCon IfaceIntTc         = tcWiredInTyCon intTyCon
 857 tcIfaceTyCon IfaceBoolTc        = tcWiredInTyCon boolTyCon
 858 tcIfaceTyCon IfaceCharTc        = tcWiredInTyCon charTyCon
 859 tcIfaceTyCon IfaceListTc        = tcWiredInTyCon listTyCon
 860 tcIfaceTyCon IfacePArrTc        = tcWiredInTyCon parrTyCon
 861 tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
 862 tcIfaceTyCon (IfaceTc ext_nm)   = do { name <- lookupIfaceExt ext_nm
 863                                      ; thing <- tcIfaceGlobal name
 864                                      ; return (check_tc (tyThingTyCon thing)) }
 865   where
 866 #ifdef DEBUG
 867     check_tc tc = case toIfaceTyCon (error "urk") tc of
 868                    IfaceTc _ -> tc
 869                    other     -> pprTrace "check_tc" (ppr tc) tc
 870 #else
 871     check_tc tc = tc
 872 #endif
 873 -- we should be okay just returning Kind constructors without extra loading
 874 tcIfaceTyCon IfaceLiftedTypeKindTc   = return liftedTypeKindTyCon
 875 tcIfaceTyCon IfaceOpenTypeKindTc     = return openTypeKindTyCon
 876 tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
 877 tcIfaceTyCon IfaceArgTypeKindTc      = return argTypeKindTyCon
 878 tcIfaceTyCon IfaceUbxTupleKindTc     = return ubxTupleKindTyCon
 879
 880 -- Even though we are in an interface file, we want to make
 881 -- sure the instances and RULES of this tycon are loaded
 882 -- Imagine: f :: Double -> Double
 883 tcWiredInTyCon :: TyCon -> IfL TyCon
 884 tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc)
 885                        ; return tc }
 886
 887 tcIfaceClass :: IfaceExtName -> IfL Class
 888 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
 889                            ; thing <- tcIfaceGlobal name
 890                            ; return (tyThingClass thing) }
 891
 892 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
 893 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
 894                         ; thing <- tcIfaceGlobal name
 895                         ; case thing of
 896                                 ADataCon dc -> return dc
 897                                 other   -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
 898
 899 tcIfaceExtId :: IfaceExtName -> IfL Id
 900 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
 901                       ; thing <- tcIfaceGlobal name
 902                       ; case thing of
 903                           AnId id -> return id
 904                           other   -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
 905 \end{code}
 906
 907 %************************************************************************
 908 %*                                                                      *
 909                 Bindings
 910 %*                                                                      *
 911 %************************************************************************
 912
 913 \begin{code}
 914 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
 915 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
 916   = bindIfaceId bndr thing_inside
 917 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
 918   = bindIfaceTyVar bndr thing_inside
 919
 920 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
 921 bindIfaceBndrs []     thing_inside = thing_inside []
 922 bindIfaceBndrs (b:bs) thing_inside
 923   = bindIfaceBndr b     $ \ b' ->
 924     bindIfaceBndrs bs   $ \ bs' ->
 925     thing_inside (b':bs')
 926
 927 -----------------------
 928 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
 929 bindIfaceId (occ, ty) thing_inside
 930   = do  { name <- newIfaceName (mkVarOccFS occ)
 931         ; ty' <- tcIfaceType ty
 932         ; let { id = mkLocalId name ty' }
 933         ; extendIfaceIdEnv [id] (thing_inside id) }
 934
 935 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
 936 bindIfaceIds bndrs thing_inside
 937   = do  { names <- newIfaceNames (map mkVarOccFS occs)
 938         ; tys' <- mappM tcIfaceType tys
 939         ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
 940         ; extendIfaceIdEnv ids (thing_inside ids) }
 941   where
 942     (occs,tys) = unzip bndrs
 943
 944
 945 -----------------------
 946 newExtCoreBndr :: IfaceIdBndr -> IfL Id
 947 newExtCoreBndr (var, ty)
 948   = do  { mod <- getIfModule
 949         ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc
 950         ; ty' <- tcIfaceType ty
 951         ; return (mkLocalId name ty') }
 952
 953 -----------------------
 954 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 955 bindIfaceTyVar (occ,kind) thing_inside
 956   = do  { name <- newIfaceName (mkTyVarOcc occ)
 957         ; tyvar <- mk_iface_tyvar name kind
 958         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 959
 960 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 961 bindIfaceTyVars bndrs thing_inside
 962   = do  { names <- newIfaceNames (map mkTyVarOcc occs)
 963         ; tyvars <- zipWithM mk_iface_tyvar names kinds
 964         ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
 965   where
 966     (occs,kinds) = unzip bndrs
 967
 968 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 969 mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind
 970                                 ; return (mkTyVar name kind)
 971                                 }
 972 \end{code}
 973