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