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