ghc/compiler/typecheck/TcModule.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 module TcModule (
   8         typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
   9         typecheckExtraDecls,
  10         TcResults(..)
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CmdLineOpts      ( DynFlag(..), DynFlags, dopt )
  16 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  17                           Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
  18                           isSourceInstDecl, mkSimpleMatch, placeHolderType
  19                         )
  20 import PrelNames        ( ioTyConName, printName,
  21                           returnIOName, bindIOName, failIOName, runMainName,
  22                           dollarMainName, itName
  23                         )
  24 import MkId             ( unsafeCoerceId )
  25 import RnHsSyn          ( RenamedHsDecl, RenamedStmt, RenamedHsExpr,
  26                           RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
  27 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
  28                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  29                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
  30                           zonkExpr, zonkIdBndr
  31                         )
  32
  33 import Rename           ( RnResult(..) )
  34 import MkIface          ( pprModDetails )
  35 import TcExpr           ( tcMonoExpr )
  36 import TcMonad
  37 import TcMType          ( newTyVarTy, zonkTcType )
  38 import TcType           ( Type, liftedTypeKind, openTypeKind,
  39                           tyVarsOfType, tcFunResultTy,
  40                           mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys,
  41                           tcSplitTyConApp_maybe, isUnitTy
  42                         )
  43 import TcMatches        ( tcStmtsAndThen )
  44 import Inst             ( LIE, emptyLIE, plusLIE )
  45 import TcBinds          ( tcTopBinds )
  46 import TcClassDcl       ( tcClassDecls2 )
  47 import TcDefaults       ( tcDefaults, defaultDefaultTys )
  48 import TcEnv            ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
  49                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
  50                           tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
  51                           tcLookupGlobalId, tcLookupTyCon,
  52                           TyThing(..), tcLookupId
  53                         )
  54 import TcRules          ( tcIfaceRules, tcSourceRules )
  55 import TcForeign        ( tcForeignImports, tcForeignExports )
  56 import TcIfaceSig       ( tcInterfaceSigs )
  57 import TcInstDcls       ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
  58 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
  59 import TcTyClsDecls     ( tcTyAndClassDecls )
  60 import CoreUnfold       ( unfoldingTemplate )
  61 import TysWiredIn       ( mkListTy, unitTy )
  62 import ErrUtils         ( printErrorsAndWarnings, errorsFound,
  63                           dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
  64 import Rules            ( extendRuleBase )
  65 import Id               ( Id, mkLocalId, idType, idUnfolding, setIdLocalExported )
  66 import Module           ( Module )
  67 import Name             ( Name, getName, getSrcLoc )
  68 import TyCon            ( tyConGenInfo )
  69 import BasicTypes       ( EP(..), RecFlag(..) )
  70 import SrcLoc           ( noSrcLoc )
  71 import Outputable
  72 import IO               ( stdout )
  73 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  74                           PackageTypeEnv, ModIface(..),
  75                           ModDetails(..), DFunId,
  76                           TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
  77                           mkTypeEnv
  78                         )
  79 import List             ( partition )
  80 \end{code}
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection{The stmt interface}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 \begin{code}
  90 typecheckStmt
  91    :: DynFlags
  92    -> PersistentCompilerState
  93    -> HomeSymbolTable
  94    -> TypeEnv              -- The interactive context's type envt
  95    -> PrintUnqualified     -- For error printing
  96    -> Module               -- Is this really needed
  97    -> [Name]               -- Names bound by the Stmt (empty for expressions)
  98    -> (RenamedStmt,        -- The stmt itself
  99        [RenamedHsDecl])    -- Plus extra decls it sucked in from interface files
 100    -> IO (Maybe (PersistentCompilerState,
 101                  TypecheckedHsExpr,
 102                  [Id],
 103                  Type))
 104                 -- The returned [Id] is the same as the input except for
 105                 -- ExprStmt, in which case the returned [Name] is [itName]
 106
 107 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls)
 108   = typecheck dflags pcs hst unqual $
 109
 110          -- use the default default settings, i.e. [Integer, Double]
 111     tcSetDefaultTys defaultDefaultTys $
 112
 113         -- Typecheck the extra declarations
 114     tcExtraDecls pcs hst this_mod iface_decls   `thenTc` \ (new_pcs, env) ->
 115
 116     tcSetEnv env                                $
 117     tcExtendGlobalTypeEnv ic_type_env           $
 118
 119         -- The real work is done here
 120     tcUserStmt names stmt               `thenTc` \ (expr, bound_ids) ->
 121
 122     traceTc (text "tcs 1") `thenNF_Tc_`
 123     zonkExpr expr                       `thenNF_Tc` \ zonked_expr ->
 124     mapNF_Tc zonkIdBndr bound_ids       `thenNF_Tc` \ zonked_ids ->
 125
 126     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
 127     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr))         `thenNF_Tc_`
 128
 129     returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
 130 \end{code}
 131
 132 Here is the grand plan, implemented in tcUserStmt
 133
 134         What you type                   The IO [HValue] that hscStmt returns
 135         -------------                   ------------------------------------
 136         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 137                                         bindings: [x,y,...]
 138
 139         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 140                                         bindings: [x,y,...]
 141
 142         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 143           [NB: result not printed]      bindings: [it]
 144
 145
 146         expr (of non-IO type,
 147           result showable)      ==>     let v = expr in print v >> return [v]
 148                                         bindings: [it]
 149
 150         expr (of non-IO type,
 151           result not showable)  ==>     error
 152
 153
 154 \begin{code}
 155 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
 156
 157 tcUserStmt names (ExprStmt expr _ loc)
 158   = ASSERT( null names )
 159     tcGetUnique                 `thenNF_Tc` \ uniq ->
 160     let
 161         fresh_it = itName uniq
 162         the_bind = FunMonoBind fresh_it False
 163                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
 164     in
 165     tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
 166                 tc_stmts [fresh_it] [
 167                     LetStmt (MonoBind the_bind [] NonRecursive),
 168                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
 169            (    traceTc (text "tcs 1a") `thenNF_Tc_`
 170                 tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
 171
 172 tcUserStmt names stmt
 173   = tc_stmts names [stmt]
 174
 175
 176 tc_stmts names stmts
 177   = tcLookupGlobalId returnIOName       `thenNF_Tc` \ return_id ->
 178     tcLookupGlobalId bindIOName         `thenNF_Tc` \ bind_id ->
 179     tcLookupGlobalId failIOName         `thenNF_Tc` \ fail_id ->
 180     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
 181     newTyVarTy liftedTypeKind           `thenNF_Tc` \ res_ty ->
 182     let
 183         io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
 184
 185                 -- mk_return builds the expression
 186                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 187         mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
 188                               (ExplicitList unitTy (map mk_item ids))
 189
 190         mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
 191                            (HsVar id)
 192     in
 193
 194     traceTc (text "tcs 2") `thenNF_Tc_`
 195     tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts  (
 196         -- Look up the names right in the middle,
 197         -- where they will all be in scope
 198         mapNF_Tc tcLookupId names                       `thenNF_Tc` \ ids ->
 199         returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
 200     )                                                   `thenTc` \ ((ids, tc_stmts), lie) ->
 201
 202         -- Simplify the context right here, so that we fail
 203         -- if there aren't enough instances.  Notably, when we see
 204         --              e
 205         -- we use tryTc_ to try         it <- e
 206         -- and then                     let it = e
 207         -- It's the simplify step that rejects the first.
 208
 209     traceTc (text "tcs 3") `thenNF_Tc_`
 210     tcSimplifyTop lie                   `thenTc` \ const_binds ->
 211     traceTc (text "tcs 4") `thenNF_Tc_`
 212
 213     returnTc (mkHsLet const_binds $
 214               HsDoOut DoExpr tc_stmts return_id bind_id fail_id
 215                       (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
 216               ids)
 217   where
 218     combine stmt (ids, stmts) = (ids, stmt:stmts)
 219 \end{code}
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsection{Typechecking an expression}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 \begin{code}
 228 typecheckExpr :: DynFlags
 229               -> PersistentCompilerState
 230               -> HomeSymbolTable
 231               -> TypeEnv           -- The interactive context's type envt
 232               -> PrintUnqualified       -- For error printing
 233               -> Module
 234               -> (RenamedHsExpr,        -- The expression itself
 235                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
 236               -> IO (Maybe (PersistentCompilerState,
 237                             TypecheckedHsExpr,
 238                             [Id],       -- always empty (matches typecheckStmt)
 239                             Type))
 240
 241 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
 242   = typecheck dflags pcs hst unqual $
 243
 244          -- use the default default settings, i.e. [Integer, Double]
 245     tcSetDefaultTys defaultDefaultTys $
 246
 247         -- Typecheck the extra declarations
 248     tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, env) ->
 249
 250         -- Now typecheck the expression
 251     tcSetEnv env                        $
 252     tcExtendGlobalTypeEnv ic_type_env   $
 253
 254     newTyVarTy openTypeKind             `thenTc` \ ty ->
 255     tcMonoExpr expr ty                  `thenTc` \ (e', lie) ->
 256     tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
 257                                         `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
 258     tcSimplifyTop lie_free              `thenTc` \ const_binds ->
 259
 260     let all_expr = mkHsLet const_binds  $
 261                    TyLam qtvs           $
 262                    DictLam dict_ids     $
 263                    mkHsLet dict_binds   $
 264                    e'
 265
 266         all_expr_ty = mkForAllTys qtvs  $
 267                       mkFunTys (map idType dict_ids) $
 268                       ty
 269     in
 270
 271     zonkExpr all_expr                           `thenNF_Tc` \ zonked_expr ->
 272     zonkTcType all_expr_ty                      `thenNF_Tc` \ zonked_ty ->
 273     ioToTc (dumpIfSet_dyn dflags
 274                 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
 275     returnTc (new_pcs, zonked_expr, [], zonked_ty)
 276
 277   where
 278     smpl_doc = ptext SLIT("main expression")
 279 \end{code}
 280
 281 %************************************************************************
 282 %*                                                                      *
 283 \subsection{Typechecking extra declarations}
 284 %*                                                                      *
 285 %************************************************************************
 286
 287 \begin{code}
 288 typecheckExtraDecls
 289    :: DynFlags
 290    -> PersistentCompilerState
 291    -> HomeSymbolTable
 292    -> PrintUnqualified     -- For error printing
 293    -> Module               -- Is this really needed
 294    -> [RenamedHsDecl]      -- extra decls sucked in from interface files
 295    -> IO (Maybe PersistentCompilerState)
 296
 297 typecheckExtraDecls dflags pcs hst unqual this_mod decls
 298  = typecheck dflags pcs hst unqual $
 299    tcExtraDecls pcs hst this_mod decls  `thenTc` \ (new_pcs, _) ->
 300    returnTc new_pcs
 301
 302 tcExtraDecls :: PersistentCompilerState
 303              -> HomeSymbolTable
 304              -> Module
 305              -> [RenamedHsDecl]
 306              -> TcM (PersistentCompilerState, TcEnv)
 307         -- Returned environment includes instances
 308
 309 tcExtraDecls pcs hst this_mod decls
 310   = tcIfaceImports this_mod decls       `thenTc` \ (env, all_things, dfuns, rules) ->
 311     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 312     let
 313         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) all_things
 314         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 315
 316         new_pcs :: PersistentCompilerState
 317         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 318                         pcs_insts = new_pcs_insts,
 319                         pcs_rules = new_pcs_rules
 320                   }
 321     in
 322         -- Initialise the instance environment
 323     tcSetEnv env (
 324         initInstEnv new_pcs hst         `thenNF_Tc` \ inst_env ->
 325         tcSetInstEnv inst_env tcGetEnv
 326     )                                   `thenNF_Tc` \ new_env ->
 327     returnTc (new_pcs, new_env)
 328 \end{code}
 329
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection{Typechecking a module}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 \begin{code}
 338 typecheckModule
 339         :: DynFlags
 340         -> PersistentCompilerState
 341         -> HomeSymbolTable
 342         -> PrintUnqualified     -- For error printing
 343         -> RnResult
 344         -> IO (Maybe (PersistentCompilerState, TcResults))
 345                         -- The new PCS is Augmented with imported information,
 346                                                 -- (but not stuff from this module)
 347
 348 data TcResults
 349   = TcResults {
 350         -- All these fields have info *just for this module*
 351         tc_env     :: TypeEnv,                  -- The top level TypeEnv
 352         tc_insts   :: [DFunId],                 -- Instances
 353         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
 354         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
 355         tc_fords   :: [TypecheckedForeignDecl]  -- Foreign import & exports.
 356     }
 357
 358
 359 typecheckModule dflags pcs hst unqual rn_result
 360   = do  { maybe_tc_result <- typecheck dflags pcs hst unqual $
 361                              tcModule pcs hst rn_result
 362         ; printTcDump dflags unqual maybe_tc_result
 363         ; return maybe_tc_result }
 364
 365 tcModule :: PersistentCompilerState
 366          -> HomeSymbolTable
 367          -> RnResult
 368          -> TcM (PersistentCompilerState, TcResults)
 369
 370 tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
 371                              rr_fixities = fix_env, rr_main = maybe_main_name })
 372   = fixTc (\ ~(unf_env, _, _) ->
 373                 -- Loop back the final environment, including the fully zonked
 374                 -- versions of bindings from this module.  In the presence of mutual
 375                 -- recursion, interface type signatures may mention variables defined
 376                 -- in this module, which is why the knot is so big
 377
 378                 -- Type-check the type and class decls, and all imported decls
 379         tcImports unf_env pcs hst this_mod
 380                   tycl_decls iface_inst_decls iface_rule_decls     `thenTc` \ (env1, new_pcs) ->
 381
 382         tcSetEnv env1                           $
 383
 384                 -- Do the source-language instances, including derivings
 385         initInstEnv new_pcs hst                 `thenNF_Tc` \ inst_env1 ->
 386         tcInstDecls1 (pcs_PRS new_pcs) inst_env1
 387                      fix_env this_mod
 388                      tycl_decls src_inst_decls  `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
 389         tcSetInstEnv inst_env2                  $
 390
 391         -- Foreign import declarations next
 392         traceTc (text "Tc4")                    `thenNF_Tc_`
 393         tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
 394         tcExtendGlobalValEnv fo_ids             $
 395
 396         -- Default declarations
 397         tcDefaults decls                        `thenTc` \ defaulting_tys ->
 398         tcSetDefaultTys defaulting_tys          $
 399
 400         -- Value declarations next.
 401         -- We also typecheck any extra binds that came out of the "deriving" process
 402         traceTc (text "Default types" <+> ppr defaulting_tys)   `thenNF_Tc_`
 403         traceTc (text "Tc5")                            `thenNF_Tc_`
 404         tcTopBinds (val_binds `ThenBinds` deriv_binds)  `thenTc` \ ((val_binds, env2), lie_valdecls) ->
 405
 406         -- Second pass over class and instance declarations,
 407         -- plus rules and foreign exports, to generate bindings
 408         tcSetEnv env2                           $
 409         traceTc (text "Tc6")                    `thenNF_Tc_`
 410         traceTc (ppr (getTcGEnv env2))          `thenNF_Tc_`
 411         tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
 412         tcExtendGlobalValEnv dm_ids             $
 413         traceTc (text "Tc7")                    `thenNF_Tc_`
 414         tcInstDecls2 inst_info                  `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 415         traceTc (text "Tc8")                    `thenNF_Tc_`
 416         tcForeignExports decls                  `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
 417         traceTc (text "Tc9")                    `thenNF_Tc_`
 418         tcSourceRules src_rule_decls            `thenNF_Tc` \ (lie_rules,     src_rules) ->
 419
 420                 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
 421         traceTc (text "Tc10")                   `thenNF_Tc_`
 422         tcCheckMain maybe_main_name             `thenTc` \ (main_bind, lie_main) ->
 423
 424              -- Deal with constant or ambiguous InstIds.  How could
 425              -- there be ambiguous ones?  They can only arise if a
 426              -- top-level decl falls under the monomorphism
 427              -- restriction, and no subsequent decl instantiates its
 428              -- type.  (Usually, ambiguous type variables are resolved
 429              -- during the generalisation step.)
 430              --
 431              -- Note that we must do this *after* tcCheckMain, because of the
 432              -- following bizarre case:
 433              --         main = return ()
 434              -- Here, we infer main :: forall a. m a, where m is a free
 435              -- type variable.  tcCheckMain will unify it with IO, and that
 436              -- must happen before tcSimplifyTop, since the latter will report
 437              -- m as ambiguous
 438         let
 439             lie_alldecls = lie_valdecls  `plusLIE`
 440                            lie_instdecls `plusLIE`
 441                            lie_clasdecls `plusLIE`
 442                            lie_fodecls   `plusLIE`
 443                            lie_rules     `plusLIE`
 444                            lie_main
 445         in
 446         tcSimplifyTop lie_alldecls      `thenTc` \ const_inst_binds ->
 447         traceTc (text "endsimpltop")    `thenTc_`
 448
 449             -- Backsubstitution.    This must be done last.
 450             -- Even tcSimplifyTop may do some unification.
 451         let
 452             all_binds = val_binds        `AndMonoBinds`
 453                         inst_binds       `AndMonoBinds`
 454                         cls_dm_binds     `AndMonoBinds`
 455                         const_inst_binds `AndMonoBinds`
 456                         foe_binds        `AndMonoBinds`
 457                         main_bind
 458         in
 459         traceTc (text "Tc7")            `thenNF_Tc_`
 460         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
 461         tcSetEnv final_env              $
 462                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 463         traceTc (text "Tc8")            `thenNF_Tc_`
 464         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 465         traceTc (text "Tc9")            `thenNF_Tc_`
 466         zonkRules src_rules             `thenNF_Tc` \ src_rules' ->
 467
 468
 469         let     src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
 470                                 -- This is horribly crude; the env might be jolly big
 471         in
 472         traceTc (text "Tc10")           `thenNF_Tc_`
 473         returnTc (final_env,
 474                   new_pcs,
 475                   TcResults { tc_env     = mkTypeEnv src_things,
 476                               tc_insts   = map iDFunId inst_info,
 477                               tc_binds   = all_binds',
 478                               tc_fords   = foi_decls ++ foe_decls',
 479                               tc_rules   = src_rules'
 480                             }
 481         )
 482     )                   `thenTc` \ (_, pcs, tc_result) ->
 483     returnTc (pcs, tc_result)
 484   where
 485     tycl_decls = [d | TyClD d <- decls]
 486     rule_decls = [d | RuleD d <- decls]
 487     inst_decls = [d | InstD d <- decls]
 488     val_decls  = [d | ValD d  <- decls]
 489
 490     (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl            inst_decls
 491     (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
 492     val_binds                          = foldr ThenBinds EmptyBinds val_decls
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection{Typechecking interface decls}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 \begin{code}
 503 typecheckIface
 504         :: DynFlags
 505         -> PersistentCompilerState
 506         -> HomeSymbolTable
 507         -> ModIface             -- Iface for this module (just module & fixities)
 508         -> [RenamedHsDecl]
 509         -> IO (Maybe (PersistentCompilerState, ModDetails))
 510                         -- The new PCS is Augmented with imported information,
 511                         -- (but not stuff from this module).
 512
 513 typecheckIface dflags pcs hst mod_iface decls
 514   = do  { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
 515                             tcIface pcs this_mod decls
 516         ; printIfaceDump dflags maybe_tc_stuff
 517         ; return maybe_tc_stuff }
 518   where
 519     this_mod = mi_module mod_iface
 520
 521 tcIface pcs this_mod decls
 522 -- The decls are coming from this_mod's interface file, together
 523 -- with imported interface decls that belong in the "package" stuff.
 524 -- (With GHCi, all the home modules have already been processed.)
 525 -- That is why we need to do the partitioning below.
 526   = tcIfaceImports this_mod decls       `thenTc` \ (_, all_things, dfuns, rules) ->
 527
 528     let
 529         -- Do the partitioning (see notes above)
 530         (local_things, imported_things) = partition (isLocalThing this_mod) all_things
 531         (local_rules,  imported_rules)  = partition is_local_rule rules
 532         (local_dfuns,  imported_dfuns)  = partition (isLocalThing this_mod) dfuns
 533         is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
 534     in
 535     addInstDFuns (pcs_insts pcs) imported_dfuns         `thenNF_Tc` \ new_pcs_insts ->
 536     let
 537         new_pcs_pte :: PackageTypeEnv
 538         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) imported_things
 539         new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
 540
 541         new_pcs :: PersistentCompilerState
 542         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 543                         pcs_insts = new_pcs_insts,
 544                         pcs_rules = new_pcs_rules
 545                   }
 546
 547         mod_details = ModDetails { md_types = mkTypeEnv local_things,
 548                                    md_insts = local_dfuns,
 549                                    md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
 550                                    md_binds = [] }
 551                         -- All the rules from an interface are of the IfaceRuleOut form
 552     in
 553     returnTc (new_pcs, mod_details)
 554
 555
 556 tcIfaceImports :: Module
 557                -> [RenamedHsDecl]       -- All interface-file decls
 558                -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
 559 tcIfaceImports this_mod decls
 560 -- The decls are all interface-file declarations
 561   = let
 562         inst_decls = [d | InstD d <- decls]
 563         tycl_decls = [d | TyClD d <- decls]
 564         rule_decls = [d | RuleD d <- decls]
 565     in
 566     fixTc (\ ~(unf_env, _, _, _) ->
 567         -- This fixTc follows the same general plan as tcImports,
 568         -- which is better commented (below)
 569         tcTyAndClassDecls unf_env this_mod tycl_decls   `thenTc` \ tycl_things ->
 570         tcExtendGlobalEnv tycl_things                   $
 571         tcInterfaceSigs unf_env this_mod tycl_decls     `thenTc` \ sig_ids ->
 572         tcExtendGlobalValEnv sig_ids                    $
 573         tcIfaceInstDecls1 inst_decls                    `thenTc` \ dfuns ->
 574         tcIfaceRules rule_decls                         `thenTc` \ rules ->
 575         tcGetEnv                                        `thenTc` \ env ->
 576         let
 577           all_things = map AnId sig_ids ++ tycl_things
 578         in
 579         returnTc (env, all_things, dfuns, rules)
 580     )
 581
 582
 583 tcImports :: RecTcEnv
 584           -> PersistentCompilerState
 585           -> HomeSymbolTable
 586           -> Module
 587           -> [RenamedTyClDecl]
 588           -> [RenamedInstDecl]
 589           -> [RenamedRuleDecl]
 590           -> TcM (TcEnv, PersistentCompilerState)
 591
 592 -- tcImports is a slight mis-nomer.
 593 -- It deals with everything that could be an import:
 594 --      type and class decls (some source, some imported)
 595 --      interface signatures (checked lazily)
 596 --      instance decls (some source, some imported)
 597 --      rule decls (all imported)
 598 -- These can occur in source code too, of course
 599 --
 600 -- tcImports is only called when processing source code,
 601 -- so that any interface-file declarations are for other modules, not this one
 602
 603 tcImports unf_env pcs hst this_mod
 604           tycl_decls inst_decls rule_decls
 605           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 606           -- which is done lazily [ie failure just drops the pragma
 607           -- without having any global-failure effect].
 608           --
 609           -- unf_env is also used to get the pragama info
 610           -- for imported dfuns and default methods
 611
 612   = checkNoErrsTc $
 613         -- tcImports recovers internally, but if anything gave rise to
 614         -- an error we'd better stop now, to avoid a cascade
 615
 616     traceTc (text "Tc1")                                `thenNF_Tc_`
 617     tcTyAndClassDecls unf_env this_mod tycl_decls       `thenTc` \ tycl_things ->
 618     tcExtendGlobalEnv tycl_things                       $
 619
 620         -- Interface type signatures
 621         -- We tie a knot so that the Ids read out of interfaces are in scope
 622         --   when we read their pragmas.
 623         -- What we rely on is that pragmas are typechecked lazily; if
 624         --   any type errors are found (ie there's an inconsistency)
 625         --   we silently discard the pragma
 626     traceTc (text "Tc2")                        `thenNF_Tc_`
 627     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 628     tcExtendGlobalValEnv sig_ids                $
 629
 630         -- Typecheck the instance decls, includes deriving
 631         -- Note that imported dictionary functions are already
 632         -- in scope from the preceding tcInterfaceSigs
 633     traceTc (text "Tc3")                `thenNF_Tc_`
 634     tcIfaceInstDecls1 inst_decls        `thenTc` \ dfuns ->
 635     tcIfaceRules rule_decls             `thenNF_Tc` \ rules ->
 636
 637     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 638     tcGetEnv                            `thenTc` \ unf_env ->
 639     let
 640          -- sometimes we're compiling in the context of a package module
 641          -- (on the GHCi command line, for example).  In this case, we
 642          -- want to treat everything we pulled in as an imported thing.
 643         imported_things = map AnId sig_ids ++   -- All imported
 644                           filter (not . isLocalThing this_mod) tycl_things
 645
 646         new_pte :: PackageTypeEnv
 647         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 648
 649         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 650
 651         new_pcs :: PersistentCompilerState
 652         new_pcs = pcs { pcs_PTE   = new_pte,
 653                         pcs_insts = new_pcs_insts,
 654                         pcs_rules = new_pcs_rules
 655                   }
 656     in
 657     returnTc (unf_env, new_pcs)
 658
 659 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
 660 -- This is a bit gruesome.
 661 -- Usually, HsRules come only from source files; IfaceRules only from interface files
 662 -- But built-in rules appear as an IfaceRuleOut... and when compiling
 663 -- the source file for that built-in rule, we want to treat it as a source
 664 -- rule, so it gets put with the other rules for that module.
 665 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _)       = True
 666 isSourceRuleDecl this_mod (IfaceRule  _ _ _ n _ _ _) = False
 667 isSourceRuleDecl this_mod (IfaceRuleOut name _)      = isLocalThing this_mod name
 668
 669 addIfaceRules rule_base rules
 670   = foldl add_rule rule_base rules
 671   where
 672     add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
 673 \end{code}
 674
 675
 676 %************************************************************************
 677 %*                                                                      *
 678 \subsection{Checking the type of main}
 679 %*                                                                      *
 680 %************************************************************************
 681
 682 We must check that in module Main,
 683         a) Main.main is in scope
 684         b) Main.main :: forall a1...an. IO t,  for some type t
 685
 686 Then we build
 687         $main = PrelTopHandler.runMain Main.main
 688
 689 The function
 690   PrelTopHandler :: IO a -> IO ()
 691 catches the top level exceptions.
 692 It accepts a Main.main of any type (IO a).
 693
 694 \begin{code}
 695 tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
 696 tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
 697
 698 tcCheckMain (Just main_name)
 699   = tcLookupId main_name                `thenNF_Tc` \ main_id ->
 700         -- If it is not Nothing, it should be in the env
 701     tcAddSrcLoc (getSrcLoc main_id)     $
 702     tcAddErrCtxt mainCtxt               $
 703     newTyVarTy liftedTypeKind           `thenNF_Tc` \ ty ->
 704     tcMonoExpr rhs ty                   `thenTc` \ (main_expr, lie) ->
 705     zonkTcType ty                       `thenNF_Tc` \ ty ->
 706     ASSERT( is_io_unit ty )
 707     let
 708        dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
 709     in
 710     returnTc (VarMonoBind dollar_main_id main_expr, lie)
 711   where
 712     rhs = HsApp (HsVar runMainName) (HsVar main_name)
 713
 714 is_io_unit :: Type -> Bool      -- True for IO ()
 715 is_io_unit tau = case tcSplitTyConApp_maybe tau of
 716                    Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg
 717                    other            -> False
 718
 719 mainCtxt = ptext SLIT("When checking the type of 'main'")
 720 \end{code}
 721
 722
 723 %************************************************************************
 724 %*                                                                      *
 725 \subsection{Interfacing the Tc monad to the IO monad}
 726 %*                                                                      *
 727 %************************************************************************
 728
 729 \begin{code}
 730 typecheck :: DynFlags
 731           -> PersistentCompilerState
 732           -> HomeSymbolTable
 733           -> PrintUnqualified   -- For error printing
 734           -> TcM r
 735           -> IO (Maybe r)
 736
 737 typecheck dflags pcs hst unqual thing_inside
 738  = do   { showPass dflags "Typechecker";
 739         ; env <- initTcEnv hst (pcs_PTE pcs)
 740
 741         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 742
 743         ; printErrorsAndWarnings unqual errs
 744
 745         ; if errorsFound errs then
 746              return Nothing
 747            else
 748              return maybe_tc_result
 749         }
 750 \end{code}
 751
 752
 753 %************************************************************************
 754 %*                                                                      *
 755 \subsection{Dumping output}
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 \begin{code}
 760 printTcDump dflags unqual Nothing = return ()
 761 printTcDump dflags unqual (Just (_, results))
 762   = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
 763           printForUser stdout unqual (dump_tc_iface dflags results)
 764           else return ()
 765
 766        dumpIfSet_dyn dflags Opt_D_dump_tc
 767                      "Typechecked" (ppr (tc_binds results))
 768
 769
 770 printIfaceDump dflags Nothing = return ()
 771 printIfaceDump dflags (Just (_, details))
 772   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 773                      "Interface" (pprModDetails details)
 774
 775 dump_tc_iface dflags results
 776   = vcat [pprModDetails (ModDetails {md_types = tc_env results,
 777                                      md_insts = tc_insts results,
 778                                      md_rules = [], md_binds = []}) ,
 779           ppr_rules (tc_rules results),
 780
 781           if dopt Opt_Generics dflags then
 782                 ppr_gen_tycons (typeEnvTyCons (tc_env results))
 783           else
 784                 empty
 785     ]
 786
 787 ppr_rules [] = empty
 788 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
 789                       nest 4 (vcat (map ppr rs)),
 790                       ptext SLIT("#-}")]
 791
 792 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 793                            vcat (map ppr_gen_tycon tcs),
 794                            ptext SLIT("#-}")
 795                      ]
 796
 797 -- x&y are now Id's, not CoreExpr's
 798 ppr_gen_tycon tycon
 799   | Just ep <- tyConGenInfo tycon
 800   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 801
 802   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 803
 804 ppr_ep (EP from to)
 805   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
 806            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 807            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 808     ]
 809   where
 810     (_,from_tau) = tcSplitForAllTys (idType from)
 811 \end{code}