ghc/compiler/typecheck/TcModule.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 module TcModule (
   8         typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
   9         typecheckExtraDecls,
  10         TcResults(..)
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CmdLineOpts      ( DynFlag(..), DynFlags, dopt )
  16 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  17                           Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
  18                           isSourceInstDecl, mkSimpleMatch, placeHolderType, 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_cbinds  :: [TypecheckedCoreBind],    -- (external)Core value decls/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         tcCoreBinds core_binds                          `thenTc` \ core_binds' ->
 409         -- Second pass over class and instance declarations,
 410         -- plus rules and foreign exports, to generate bindings
 411         tcSetEnv env2                           $
 412         traceTc (text "Tc6")                    `thenNF_Tc_`
 413         traceTc (ppr (getTcGEnv env2))          `thenNF_Tc_`
 414         tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
 415         tcExtendGlobalValEnv dm_ids             $
 416         traceTc (text "Tc7")                    `thenNF_Tc_`
 417         tcInstDecls2 inst_info                  `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 418         traceTc (text "Tc8")                    `thenNF_Tc_`
 419         tcForeignExports this_mod decls         `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
 420         traceTc (text "Tc9")                    `thenNF_Tc_`
 421         tcSourceRules src_rule_decls            `thenNF_Tc` \ (lie_rules,     src_rules) ->
 422
 423                 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
 424         traceTc (text "Tc10")                   `thenNF_Tc_`
 425         tcCheckMain maybe_main_name             `thenTc` \ (main_bind, lie_main) ->
 426
 427              -- Deal with constant or ambiguous InstIds.  How could
 428              -- there be ambiguous ones?  They can only arise if a
 429              -- top-level decl falls under the monomorphism
 430              -- restriction, and no subsequent decl instantiates its
 431              -- type.  (Usually, ambiguous type variables are resolved
 432              -- during the generalisation step.)
 433              --
 434              -- Note that we must do this *after* tcCheckMain, because of the
 435              -- following bizarre case:
 436              --         main = return ()
 437              -- Here, we infer main :: forall a. m a, where m is a free
 438              -- type variable.  tcCheckMain will unify it with IO, and that
 439              -- must happen before tcSimplifyTop, since the latter will report
 440              -- m as ambiguous
 441         let
 442             lie_alldecls = lie_valdecls  `plusLIE`
 443                            lie_instdecls `plusLIE`
 444                            lie_clasdecls `plusLIE`
 445                            lie_fodecls   `plusLIE`
 446                            lie_rules     `plusLIE`
 447                            lie_main
 448         in
 449         tcSimplifyTop lie_alldecls      `thenTc` \ const_inst_binds ->
 450         traceTc (text "endsimpltop")    `thenTc_`
 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         zonkCoreBinds core_binds'       `thenNF_Tc` \ core_binds' ->
 465         tcSetEnv final_env              $
 466                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 467         traceTc (text "Tc8")            `thenNF_Tc_`
 468         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 469         traceTc (text "Tc9")            `thenNF_Tc_`
 470         zonkRules src_rules             `thenNF_Tc` \ src_rules' ->
 471
 472
 473         let     src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
 474                                 -- This is horribly crude; the env might be jolly big
 475         in
 476         traceTc (text "Tc10")           `thenNF_Tc_`
 477         returnTc (final_env,
 478                   new_pcs,
 479                   TcResults { tc_env     = mkTypeEnv src_things,
 480                               tc_insts   = map iDFunId inst_info,
 481                               tc_binds   = all_binds',
 482                               tc_fords   = foi_decls ++ foe_decls',
 483                               tc_cbinds  = core_binds',
 484                               tc_rules   = src_rules'
 485                             }
 486         )
 487     )                   `thenTc` \ (_, pcs, tc_result) ->
 488     returnTc (pcs, tc_result)
 489   where
 490     tycl_decls = [d | TyClD d <- decls]
 491     rule_decls = [d | RuleD d <- decls]
 492     inst_decls = [d | InstD d <- decls]
 493     val_decls  = [d | ValD d  <- decls]
 494
 495     core_binds = [d | d <- tycl_decls, isCoreDecl d]
 496
 497     (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl            inst_decls
 498     (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
 499     val_binds                          = foldr ThenBinds EmptyBinds val_decls
 500 \end{code}
 501
 502
 503 %************************************************************************
 504 %*                                                                      *
 505 \subsection{Typechecking interface decls}
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 \begin{code}
 510 typecheckIface
 511         :: DynFlags
 512         -> PersistentCompilerState
 513         -> HomeSymbolTable
 514         -> ModIface             -- Iface for this module (just module & fixities)
 515         -> [RenamedHsDecl]
 516         -> IO (Maybe (PersistentCompilerState, ModDetails))
 517                         -- The new PCS is Augmented with imported information,
 518                         -- (but not stuff from this module).
 519
 520 typecheckIface dflags pcs hst mod_iface decls
 521   = do  { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
 522                             tcIface pcs this_mod decls
 523         ; printIfaceDump dflags maybe_tc_stuff
 524         ; return maybe_tc_stuff }
 525   where
 526     this_mod = mi_module mod_iface
 527
 528 tcIface pcs this_mod decls
 529 -- The decls are coming from this_mod's interface file, together
 530 -- with imported interface decls that belong in the "package" stuff.
 531 -- (With GHCi, all the home modules have already been processed.)
 532 -- That is why we need to do the partitioning below.
 533   = tcIfaceImports this_mod decls       `thenTc` \ (_, all_things, dfuns, rules) ->
 534
 535     let
 536         -- Do the partitioning (see notes above)
 537         (local_things, imported_things) = partition (isLocalThing this_mod) all_things
 538         (local_rules,  imported_rules)  = partition is_local_rule rules
 539         (local_dfuns,  imported_dfuns)  = partition (isLocalThing this_mod) dfuns
 540         is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
 541     in
 542     addInstDFuns (pcs_insts pcs) imported_dfuns         `thenNF_Tc` \ new_pcs_insts ->
 543     let
 544         new_pcs_pte :: PackageTypeEnv
 545         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) imported_things
 546         new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
 547
 548         new_pcs :: PersistentCompilerState
 549         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 550                         pcs_insts = new_pcs_insts,
 551                         pcs_rules = new_pcs_rules
 552                   }
 553
 554         mod_details = ModDetails { md_types = mkTypeEnv local_things,
 555                                    md_insts = local_dfuns,
 556                                    md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
 557                                    md_binds = [] }
 558                         -- All the rules from an interface are of the IfaceRuleOut form
 559     in
 560     returnTc (new_pcs, mod_details)
 561
 562
 563 tcIfaceImports :: Module
 564                -> [RenamedHsDecl]       -- All interface-file decls
 565                -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
 566 tcIfaceImports this_mod decls
 567 -- The decls are all interface-file declarations
 568   = let
 569         inst_decls = [d | InstD d <- decls]
 570         tycl_decls = [d | TyClD d <- decls]
 571         rule_decls = [d | RuleD d <- decls]
 572     in
 573     fixTc (\ ~(unf_env, _, _, _) ->
 574         -- This fixTc follows the same general plan as tcImports,
 575         -- which is better commented (below)
 576         tcTyAndClassDecls unf_env this_mod tycl_decls   `thenTc` \ tycl_things ->
 577         tcExtendGlobalEnv tycl_things                   $
 578         tcInterfaceSigs unf_env this_mod tycl_decls     `thenTc` \ sig_ids ->
 579         tcExtendGlobalValEnv sig_ids                    $
 580         tcIfaceInstDecls1 inst_decls                    `thenTc` \ dfuns ->
 581         tcIfaceRules rule_decls                         `thenTc` \ rules ->
 582         tcGetEnv                                        `thenTc` \ env ->
 583         let
 584           all_things = map AnId sig_ids ++ tycl_things
 585         in
 586         returnTc (env, all_things, dfuns, rules)
 587     )
 588
 589
 590 tcImports :: RecTcEnv
 591           -> PersistentCompilerState
 592           -> HomeSymbolTable
 593           -> Module
 594           -> [RenamedTyClDecl]
 595           -> [RenamedInstDecl]
 596           -> [RenamedRuleDecl]
 597           -> TcM (TcEnv, PersistentCompilerState)
 598
 599 -- tcImports is a slight mis-nomer.
 600 -- It deals with everything that could be an import:
 601 --      type and class decls (some source, some imported)
 602 --      interface signatures (checked lazily)
 603 --      instance decls (some source, some imported)
 604 --      rule decls (all imported)
 605 -- These can occur in source code too, of course
 606 --
 607 -- tcImports is only called when processing source code,
 608 -- so that any interface-file declarations are for other modules, not this one
 609
 610 tcImports unf_env pcs hst this_mod
 611           tycl_decls inst_decls rule_decls
 612           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 613           -- which is done lazily [ie failure just drops the pragma
 614           -- without having any global-failure effect].
 615           --
 616           -- unf_env is also used to get the pragama info
 617           -- for imported dfuns and default methods
 618
 619   = checkNoErrsTc $
 620         -- tcImports recovers internally, but if anything gave rise to
 621         -- an error we'd better stop now, to avoid a cascade
 622
 623     traceTc (text "Tc1")                                `thenNF_Tc_`
 624     tcTyAndClassDecls unf_env this_mod tycl_decls       `thenTc` \ tycl_things ->
 625     tcExtendGlobalEnv tycl_things                       $
 626
 627         -- Interface type signatures
 628         -- We tie a knot so that the Ids read out of interfaces are in scope
 629         --   when we read their pragmas.
 630         -- What we rely on is that pragmas are typechecked lazily; if
 631         --   any type errors are found (ie there's an inconsistency)
 632         --   we silently discard the pragma
 633     traceTc (text "Tc2")                        `thenNF_Tc_`
 634     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 635     tcExtendGlobalValEnv sig_ids                $
 636
 637         -- Typecheck the instance decls, includes deriving
 638         -- Note that imported dictionary functions are already
 639         -- in scope from the preceding tcInterfaceSigs
 640     traceTc (text "Tc3")                `thenNF_Tc_`
 641     tcIfaceInstDecls1 inst_decls        `thenTc` \ dfuns ->
 642     tcIfaceRules rule_decls             `thenNF_Tc` \ rules ->
 643
 644     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 645     tcGetEnv                            `thenTc` \ unf_env ->
 646     let
 647          -- sometimes we're compiling in the context of a package module
 648          -- (on the GHCi command line, for example).  In this case, we
 649          -- want to treat everything we pulled in as an imported thing.
 650         imported_things = map AnId sig_ids ++   -- All imported
 651                           filter (not . isLocalThing this_mod) tycl_things
 652
 653         new_pte :: PackageTypeEnv
 654         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 655
 656         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 657
 658         new_pcs :: PersistentCompilerState
 659         new_pcs = pcs { pcs_PTE   = new_pte,
 660                         pcs_insts = new_pcs_insts,
 661                         pcs_rules = new_pcs_rules
 662                   }
 663     in
 664     returnTc (unf_env, new_pcs)
 665
 666 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
 667 -- This is a bit gruesome.
 668 -- Usually, HsRules come only from source files; IfaceRules only from interface files
 669 -- But built-in rules appear as an IfaceRuleOut... and when compiling
 670 -- the source file for that built-in rule, we want to treat it as a source
 671 -- rule, so it gets put with the other rules for that module.
 672 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _)       = True
 673 isSourceRuleDecl this_mod (IfaceRule  _ _ _ n _ _ _) = False
 674 isSourceRuleDecl this_mod (IfaceRuleOut name _)      = isLocalThing this_mod name
 675
 676 addIfaceRules rule_base rules
 677   = foldl add_rule rule_base rules
 678   where
 679     add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
 680 \end{code}
 681
 682
 683 %************************************************************************
 684 %*                                                                      *
 685 \subsection{Checking the type of main}
 686 %*                                                                      *
 687 %************************************************************************
 688
 689 We must check that in module Main,
 690         a) Main.main is in scope
 691         b) Main.main :: forall a1...an. IO t,  for some type t
 692
 693 Then we build
 694         $main = PrelTopHandler.runMain Main.main
 695
 696 The function
 697   PrelTopHandler :: IO a -> IO ()
 698 catches the top level exceptions.
 699 It accepts a Main.main of any type (IO a).
 700
 701 \begin{code}
 702 tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
 703 tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
 704
 705 tcCheckMain (Just main_name)
 706   = tcLookupId main_name                `thenNF_Tc` \ main_id ->
 707         -- If it is not Nothing, it should be in the env
 708     tcAddSrcLoc (getSrcLoc main_id)     $
 709     tcAddErrCtxt mainCtxt               $
 710     newTyVarTy liftedTypeKind           `thenNF_Tc` \ ty ->
 711     tcMonoExpr rhs ty                   `thenTc` \ (main_expr, lie) ->
 712     zonkTcType ty                       `thenNF_Tc` \ ty ->
 713     ASSERT( is_io_unit ty )
 714     let
 715        dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
 716     in
 717     returnTc (VarMonoBind dollar_main_id main_expr, lie)
 718   where
 719     rhs = HsApp (HsVar runMainName) (HsVar main_name)
 720
 721 is_io_unit :: Type -> Bool      -- True for IO ()
 722 is_io_unit tau = case tcSplitTyConApp_maybe tau of
 723                    Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg
 724                    other            -> False
 725
 726 mainCtxt = ptext SLIT("When checking the type of 'main'")
 727 \end{code}
 728
 729
 730 %************************************************************************
 731 %*                                                                      *
 732 \subsection{Interfacing the Tc monad to the IO monad}
 733 %*                                                                      *
 734 %************************************************************************
 735
 736 \begin{code}
 737 typecheck :: DynFlags
 738           -> PersistentCompilerState
 739           -> HomeSymbolTable
 740           -> PrintUnqualified   -- For error printing
 741           -> TcM r
 742           -> IO (Maybe r)
 743
 744 typecheck dflags pcs hst unqual thing_inside
 745  = do   { showPass dflags "Typechecker";
 746         ; env <- initTcEnv hst (pcs_PTE pcs)
 747
 748         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 749
 750         ; printErrorsAndWarnings unqual errs
 751
 752         ; if errorsFound errs then
 753              return Nothing
 754            else
 755              return maybe_tc_result
 756         }
 757 \end{code}
 758
 759
 760 %************************************************************************
 761 %*                                                                      *
 762 \subsection{Dumping output}
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 \begin{code}
 767 printTcDump dflags unqual Nothing = return ()
 768 printTcDump dflags unqual (Just (_, results))
 769   = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
 770           printForUser stdout unqual (dump_tc_iface dflags results)
 771           else return ()
 772
 773        dumpIfSet_dyn dflags Opt_D_dump_tc
 774         -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
 775                      "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
 776
 777
 778 printIfaceDump dflags Nothing = return ()
 779 printIfaceDump dflags (Just (_, details))
 780   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 781                      "Interface" (pprModDetails details)
 782
 783 dump_tc_iface dflags results
 784   = vcat [pprModDetails (ModDetails {md_types = tc_env results,
 785                                      md_insts = tc_insts results,
 786                                      md_rules = [], md_binds = []}) ,
 787           ppr_rules (tc_rules results),
 788
 789           if dopt Opt_Generics dflags then
 790                 ppr_gen_tycons (typeEnvTyCons (tc_env results))
 791           else
 792                 empty
 793     ]
 794
 795 ppr_rules [] = empty
 796 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
 797                       nest 4 (vcat (map ppr rs)),
 798                       ptext SLIT("#-}")]
 799
 800 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 801                            vcat (map ppr_gen_tycon tcs),
 802                            ptext SLIT("#-}")
 803                      ]
 804
 805 -- x&y are now Id's, not CoreExpr's
 806 ppr_gen_tycon tycon
 807   | Just ep <- tyConGenInfo tycon
 808   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 809
 810   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 811
 812 ppr_ep (EP from to)
 813   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
 814            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 815            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 816     ]
 817   where
 818     (_,from_tau) = tcSplitForAllTys (idType from)
 819 \end{code}