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