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
 452             -- Backsubstitution.    This must be done last.
 453             -- Even tcSimplifyTop may do some unification.
 454         let
 455             all_binds = val_binds        `AndMonoBinds`
 456                         inst_binds       `AndMonoBinds`
 457                         cls_dm_binds     `AndMonoBinds`
 458                         const_inst_binds `AndMonoBinds`
 459                         foe_binds        `AndMonoBinds`
 460                         main_bind
 461         in
 462         traceTc (text "Tc7")            `thenNF_Tc_`
 463         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
 464         tcSetEnv final_env              $
 465                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 466         traceTc (text "Tc8")            `thenNF_Tc_`
 467         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 468         traceTc (text "Tc9")            `thenNF_Tc_`
 469         zonkRules src_rules             `thenNF_Tc` \ src_rules' ->
 470
 471
 472         let     src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
 473                                 -- This is horribly crude; the env might be jolly big
 474         in
 475         traceTc (text "Tc10")           `thenNF_Tc_`
 476         returnTc (final_env,
 477                   new_pcs,
 478                   TcResults { tc_env     = mkTypeEnv src_things,
 479                               tc_insts   = map iDFunId inst_info,
 480                               tc_binds   = all_binds',
 481                               tc_fords   = foi_decls ++ foe_decls',
 482                               tc_rules   = src_rules'
 483                             }
 484         )
 485     )                   `thenTc` \ (_, pcs, tc_result) ->
 486     returnTc (pcs, tc_result)
 487   where
 488     tycl_decls = [d | TyClD d <- decls]
 489     rule_decls = [d | RuleD d <- decls]
 490     inst_decls = [d | InstD d <- decls]
 491     val_decls  = [d | ValD d  <- decls]
 492
 493     core_binds = [d | d <- tycl_decls, isCoreDecl d]
 494
 495     (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl            inst_decls
 496     (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
 497     val_binds                          = foldr ThenBinds EmptyBinds val_decls
 498 \end{code}
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsection{Typechecking interface decls}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 \begin{code}
 508 typecheckIface
 509         :: DynFlags
 510         -> PersistentCompilerState
 511         -> HomeSymbolTable
 512         -> ModIface             -- Iface for this module (just module & fixities)
 513         -> [RenamedHsDecl]
 514         -> IO (Maybe (PersistentCompilerState, ModDetails))
 515                         -- The new PCS is Augmented with imported information,
 516                         -- (but not stuff from this module).
 517
 518 typecheckIface dflags pcs hst mod_iface decls
 519   = do  { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
 520                             tcIface pcs this_mod decls
 521         ; printIfaceDump dflags maybe_tc_stuff
 522         ; return maybe_tc_stuff }
 523   where
 524     this_mod = mi_module mod_iface
 525
 526 tcIface pcs this_mod decls
 527 -- The decls are coming from this_mod's interface file, together
 528 -- with imported interface decls that belong in the "package" stuff.
 529 -- (With GHCi, all the home modules have already been processed.)
 530 -- That is why we need to do the partitioning below.
 531   = tcIfaceImports this_mod decls       `thenTc` \ (_, all_things, dfuns, rules) ->
 532
 533     let
 534         -- Do the partitioning (see notes above)
 535         (local_things, imported_things) = partition (isLocalThing this_mod) all_things
 536         (local_rules,  imported_rules)  = partition is_local_rule rules
 537         (local_dfuns,  imported_dfuns)  = partition (isLocalThing this_mod) dfuns
 538         is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
 539     in
 540     addInstDFuns (pcs_insts pcs) imported_dfuns         `thenNF_Tc` \ new_pcs_insts ->
 541     let
 542         new_pcs_pte :: PackageTypeEnv
 543         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) imported_things
 544         new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
 545
 546         new_pcs :: PersistentCompilerState
 547         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 548                         pcs_insts = new_pcs_insts,
 549                         pcs_rules = new_pcs_rules
 550                   }
 551
 552         mod_details = ModDetails { md_types = mkTypeEnv local_things,
 553                                    md_insts = local_dfuns,
 554                                    md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
 555                                    md_binds = [] }
 556                         -- All the rules from an interface are of the IfaceRuleOut form
 557     in
 558     returnTc (new_pcs, mod_details)
 559
 560
 561 tcIfaceImports :: Module
 562                -> [RenamedHsDecl]       -- All interface-file decls
 563                -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
 564 tcIfaceImports this_mod decls
 565 -- The decls are all interface-file declarations
 566   = let
 567         inst_decls = [d | InstD d <- decls]
 568         tycl_decls = [d | TyClD d <- decls]
 569         rule_decls = [d | RuleD d <- decls]
 570     in
 571     fixTc (\ ~(unf_env, _, _, _) ->
 572         -- This fixTc follows the same general plan as tcImports,
 573         -- which is better commented (below)
 574         tcTyAndClassDecls this_mod tycl_decls           `thenTc` \ tycl_things ->
 575         tcExtendGlobalEnv tycl_things                   $
 576         tcInterfaceSigs unf_env this_mod tycl_decls     `thenTc` \ sig_ids ->
 577         tcExtendGlobalValEnv sig_ids                    $
 578         tcIfaceInstDecls1 inst_decls                    `thenTc` \ dfuns ->
 579         tcIfaceRules rule_decls                         `thenTc` \ rules ->
 580         tcGetEnv                                        `thenTc` \ env ->
 581         let
 582           all_things = map AnId sig_ids ++ tycl_things
 583         in
 584         returnTc (env, all_things, dfuns, rules)
 585     )
 586
 587
 588 tcImports :: RecTcEnv
 589           -> PersistentCompilerState
 590           -> HomeSymbolTable
 591           -> Module
 592           -> [RenamedTyClDecl]
 593           -> [RenamedInstDecl]
 594           -> [RenamedRuleDecl]
 595           -> TcM (TcEnv, PersistentCompilerState)
 596
 597 -- tcImports is a slight mis-nomer.
 598 -- It deals with everything that could be an import:
 599 --      type and class decls (some source, some imported)
 600 --      interface signatures (checked lazily)
 601 --      instance decls (some source, some imported)
 602 --      rule decls (all imported)
 603 -- These can occur in source code too, of course
 604 --
 605 -- tcImports is only called when processing source code,
 606 -- so that any interface-file declarations are for other modules, not this one
 607
 608 tcImports unf_env pcs hst this_mod
 609           tycl_decls inst_decls rule_decls
 610           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 611           -- which is done lazily [ie failure just drops the pragma
 612           -- without having any global-failure effect].
 613           --
 614           -- unf_env is also used to get the pragama info
 615           -- for imported dfuns and default methods
 616
 617   = checkNoErrsTc $
 618         -- tcImports recovers internally, but if anything gave rise to
 619         -- an error we'd better stop now, to avoid a cascade
 620
 621     traceTc (text "Tc1")                        `thenNF_Tc_`
 622     tcTyAndClassDecls  this_mod tycl_decls      `thenTc` \ tycl_things ->
 623     tcExtendGlobalEnv tycl_things               $
 624
 625         -- Interface type signatures
 626         -- We tie a knot so that the Ids read out of interfaces are in scope
 627         --   when we read their pragmas.
 628         -- What we rely on is that pragmas are typechecked lazily; if
 629         --   any type errors are found (ie there's an inconsistency)
 630         --   we silently discard the pragma
 631     traceTc (text "Tc2")                        `thenNF_Tc_`
 632     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 633     tcExtendGlobalValEnv sig_ids                $
 634
 635         -- Typecheck the instance decls, includes deriving
 636         -- Note that imported dictionary functions are already
 637         -- in scope from the preceding tcInterfaceSigs
 638     traceTc (text "Tc3")                `thenNF_Tc_`
 639     tcIfaceInstDecls1 inst_decls        `thenTc` \ dfuns ->
 640     tcIfaceRules rule_decls             `thenNF_Tc` \ rules ->
 641
 642     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 643     tcGetEnv                            `thenTc` \ unf_env ->
 644     let
 645          -- sometimes we're compiling in the context of a package module
 646          -- (on the GHCi command line, for example).  In this case, we
 647          -- want to treat everything we pulled in as an imported thing.
 648         imported_things = map AnId sig_ids ++   -- All imported
 649                           filter (not . isLocalThing this_mod) tycl_things
 650
 651         new_pte :: PackageTypeEnv
 652         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 653
 654         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 655
 656         new_pcs :: PersistentCompilerState
 657         new_pcs = pcs { pcs_PTE   = new_pte,
 658                         pcs_insts = new_pcs_insts,
 659                         pcs_rules = new_pcs_rules
 660                   }
 661     in
 662     returnTc (unf_env, new_pcs)
 663
 664 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
 665 -- This is a bit gruesome.
 666 -- Usually, HsRules come only from source files; IfaceRules only from interface files
 667 -- But built-in rules appear as an IfaceRuleOut... and when compiling
 668 -- the source file for that built-in rule, we want to treat it as a source
 669 -- rule, so it gets put with the other rules for that module.
 670 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _)       = True
 671 isSourceRuleDecl this_mod (IfaceRule  _ _ _ n _ _ _) = False
 672 isSourceRuleDecl this_mod (IfaceRuleOut name _)      = isLocalThing this_mod name
 673
 674 addIfaceRules rule_base rules
 675   = foldl add_rule rule_base rules
 676   where
 677     add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
 678 \end{code}
 679
 680 \begin{code}
 681 typecheckCoreModule
 682         :: DynFlags
 683         -> PersistentCompilerState
 684         -> HomeSymbolTable
 685         -> ModIface             -- Iface for this module (just module & fixities)
 686         -> [RenamedHsDecl]
 687         -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
 688 typecheckCoreModule dflags pcs hst mod_iface decls
 689   = do  { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
 690                             tcCoreDecls this_mod decls
 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 result -> return (Just (pcs, result)) }
 699   where
 700     this_mod = mi_module mod_iface
 701     core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
 702
 703
 704 tcCoreDecls :: Module
 705             -> [RenamedHsDecl]  -- All interface-file decls
 706             -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
 707 tcCoreDecls this_mod decls
 708 -- The decls are all TyClD declarations coming from External Core input.
 709   = let
 710         tycl_decls = [d | TyClD d <- decls]
 711         rule_decls = [d | RuleD d <- decls]
 712         core_decls = filter isCoreDecl tycl_decls
 713     in
 714     fixTc (\ ~(unf_env, _) ->
 715         -- This fixTc follows the same general plan as tcImports,
 716         -- which is better commented.
 717         -- [ Q: do we need to tie a knot for External Core? ]
 718         tcTyAndClassDecls this_mod tycl_decls           `thenTc` \ tycl_things ->
 719         tcExtendGlobalEnv tycl_things                   $
 720
 721         tcInterfaceSigs unf_env this_mod tycl_decls     `thenTc` \ sig_ids ->
 722         tcExtendGlobalValEnv sig_ids                    $
 723
 724         tcCoreBinds core_decls                          `thenTc` \ core_prs ->
 725         let
 726            local_ids = map fst core_prs
 727         in
 728         tcExtendGlobalValEnv local_ids                  $
 729
 730         tcIfaceRules rule_decls                         `thenTc` \ rules ->
 731
 732         let
 733            src_things = filter (isLocalThing this_mod) tycl_things
 734                         ++ map AnId local_ids
 735         in
 736         tcGetEnv                                        `thenNF_Tc` \ env ->
 737         returnTc (env, (mkTypeEnv src_things, core_prs, rules))
 738     )                                                   `thenTc` \ (_, result) ->
 739     returnTc result
 740 \end{code}
 741
 742
 743 %************************************************************************
 744 %*                                                                      *
 745 \subsection{Checking the type of main}
 746 %*                                                                      *
 747 %************************************************************************
 748
 749 We must check that in module Main,
 750         a) Main.main is in scope
 751         b) Main.main :: forall a1...an. IO t,  for some type t
 752
 753 Then we build
 754         $main = PrelTopHandler.runMain Main.main
 755
 756 The function
 757   PrelTopHandler :: IO a -> IO ()
 758 catches the top level exceptions.
 759 It accepts a Main.main of any type (IO a).
 760
 761 \begin{code}
 762 tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
 763 tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
 764
 765 tcCheckMain (Just main_name)
 766   = tcLookupId main_name                `thenNF_Tc` \ main_id ->
 767         -- If it is not Nothing, it should be in the env
 768     tcAddSrcLoc (getSrcLoc main_id)     $
 769     tcAddErrCtxt mainCtxt               $
 770     newTyVarTy liftedTypeKind           `thenNF_Tc` \ ty ->
 771     tcMonoExpr rhs ty                   `thenTc` \ (main_expr, lie) ->
 772     zonkTcType ty                       `thenNF_Tc` \ ty ->
 773     ASSERT( is_io_unit ty )
 774     let
 775        dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
 776     in
 777     returnTc (VarMonoBind dollar_main_id main_expr, lie)
 778   where
 779     rhs = HsApp (HsVar runMainName) (HsVar main_name)
 780
 781 is_io_unit :: Type -> Bool      -- True for IO ()
 782 is_io_unit tau = case tcSplitTyConApp_maybe tau of
 783                    Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg
 784                    other            -> False
 785
 786 mainCtxt = ptext SLIT("When checking the type of 'main'")
 787 \end{code}
 788
 789
 790 %************************************************************************
 791 %*                                                                      *
 792 \subsection{Interfacing the Tc monad to the IO monad}
 793 %*                                                                      *
 794 %************************************************************************
 795
 796 \begin{code}
 797 typecheck :: DynFlags
 798           -> PersistentCompilerState
 799           -> HomeSymbolTable
 800           -> PrintUnqualified   -- For error printing
 801           -> TcM r
 802           -> IO (Maybe r)
 803
 804 typecheck dflags pcs hst unqual thing_inside
 805  = do   { showPass dflags "Typechecker";
 806         ; env <- initTcEnv hst (pcs_PTE pcs)
 807
 808         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 809
 810         ; printErrorsAndWarnings unqual errs
 811
 812         ; if errorsFound errs then
 813              return Nothing
 814            else
 815              return maybe_tc_result
 816         }
 817 \end{code}
 818
 819
 820 %************************************************************************
 821 %*                                                                      *
 822 \subsection{Dumping output}
 823 %*                                                                      *
 824 %************************************************************************
 825
 826 \begin{code}
 827 printTcDump dflags unqual Nothing = return ()
 828 printTcDump dflags unqual (Just (_, results))
 829   = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
 830           printForUser stdout unqual (dump_tc_iface dflags results)
 831           else return ()
 832
 833        dumpIfSet_dyn dflags Opt_D_dump_tc
 834         -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
 835                      "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
 836
 837
 838 printIfaceDump dflags Nothing = return ()
 839 printIfaceDump dflags (Just (_, details))
 840   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 841                      "Interface" (pprModDetails details)
 842
 843 dump_tc_iface dflags results
 844   = vcat [pprModDetails (ModDetails {md_types = tc_env results,
 845                                      md_insts = tc_insts results,
 846                                      md_rules = [], md_binds = []}) ,
 847           ppr_rules (tc_rules results),
 848
 849           if dopt Opt_Generics dflags then
 850                 ppr_gen_tycons (typeEnvTyCons (tc_env results))
 851           else
 852                 empty
 853     ]
 854
 855 ppr_rules [] = empty
 856 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
 857                       nest 4 (vcat (map ppr rs)),
 858                       ptext SLIT("#-}")]
 859
 860 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 861                            vcat (map ppr_gen_tycon tcs),
 862                            ptext SLIT("#-}")
 863                      ]
 864
 865 -- x&y are now Id's, not CoreExpr's
 866 ppr_gen_tycon tycon
 867   | Just ep <- tyConGenInfo tycon
 868   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 869
 870   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 871
 872 ppr_ep (EP from to)
 873   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
 874            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 875            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 876     ]
 877   where
 878     (_,from_tau) = tcSplitForAllTys (idType from)
 879 \end{code}