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, TcResults(..)
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CmdLineOpts      ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
  14 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  15                           Stmt(..), InPat(..), HsMatchContext(..),
  16                           isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
  17                         )
  18 import HsTypes          ( toHsType )
  19 import PrelNames        ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
  20                           returnIOName, bindIOName, failIOName,
  21                           itName
  22                         )
  23 import MkId             ( unsafeCoerceId )
  24 import RnHsSyn          ( RenamedHsBinds, RenamedHsDecl, RenamedStmt )
  25 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
  26                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  27                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
  28                           zonkExpr, zonkIdBndr
  29                         )
  30
  31
  32 import TcMonad
  33 import TcType           ( newTyVarTy, zonkTcType, tcInstType )
  34 import TcMatches        ( tcStmtsAndThen )
  35 import TcUnify          ( unifyTauTy )
  36 import Inst             ( emptyLIE, plusLIE )
  37 import TcBinds          ( tcTopBinds )
  38 import TcClassDcl       ( tcClassDecls2 )
  39 import TcDefaults       ( tcDefaults, defaultDefaultTys )
  40 import TcEnv            ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
  41                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
  42                           tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon,
  43                           TcTyThing(..), tcLookupId
  44                         )
  45 import TcRules          ( tcIfaceRules, tcSourceRules )
  46 import TcForeign        ( tcForeignImports, tcForeignExports )
  47 import TcIfaceSig       ( tcInterfaceSigs )
  48 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  49 import TcSimplify       ( tcSimplifyTop )
  50 import TcTyClsDecls     ( tcTyAndClassDecls )
  51
  52 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
  53 import TysWiredIn       ( mkListTy, unitTy )
  54 import Type             ( funResultTy, splitForAllTys,
  55                           liftedTypeKind, mkTyConApp, tidyType )
  56 import ErrUtils         ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
  57 import Id               ( Id, idType, idName, isLocalId, idUnfolding )
  58 import Module           ( Module, isHomeModule, moduleName )
  59 import Name             ( Name, toRdrName, isGlobalName )
  60 import Name             ( nameEnvElts, lookupNameEnv )
  61 import TyCon            ( tyConGenInfo )
  62 import Util
  63 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
  64 import SrcLoc           ( noSrcLoc )
  65 import Outputable
  66 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  67                           PackageTypeEnv, ModIface(..),
  68                           TypeEnv, extendTypeEnvList,
  69                           TyThing(..), implicitTyThingIds,
  70                           mkTypeEnv
  71                         )
  72 import Rules ( ruleBaseIds )
  73 import VarSet
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{The stmt interface}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 typecheckStmt :: DynFlags
  85               -> PersistentCompilerState
  86               -> HomeSymbolTable
  87               -> TypeEnv                -- The interactive context's type envt
  88               -> PrintUnqualified       -- For error printing
  89               -> Module                 -- Is this really needed
  90               -> [Name]                 -- Names bound by the Stmt (empty for expressions)
  91               -> (SyntaxMap,
  92                   RenamedStmt,          -- The stmt itself
  93                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
  94               -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id]))
  95                         -- The returned [Name] is the same as the input except for
  96                         -- ExprStmt, in which case the returned [Name] is [itName]
  97
  98 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls)
  99   = typecheck dflags syn_map pcs hst unqual $
 100
 101          -- use the default default settings, i.e. [Integer, Double]
 102     tcSetDefaultTys defaultDefaultTys $
 103
 104         -- Typecheck the extra declarations
 105     fixTc (\ ~(unf_env, _, _, _, _) ->
 106         tcImports unf_env pcs hst get_fixity this_mod iface_decls
 107     )                   `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 108     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
 109
 110     tcSetEnv env                                $
 111     tcExtendGlobalTypeEnv ic_type_env           $
 112
 113         -- The real work is done here
 114     tcUserStmt names stmt               `thenTc` \ (expr, bound_ids) ->
 115
 116     traceTc (text "tcs 1") `thenNF_Tc_`
 117     zonkExpr expr                       `thenNF_Tc` \ zonked_expr ->
 118     mapNF_Tc zonkIdBndr bound_ids       `thenNF_Tc` \ zonked_ids ->
 119
 120     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
 121     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr))         `thenNF_Tc_`
 122
 123     returnTc (new_pcs, zonked_expr, zonked_ids)
 124
 125   where
 126     get_fixity :: Name -> Maybe Fixity
 127     get_fixity n = pprPanic "typecheckExpr" (ppr n)
 128 \end{code}
 129
 130 Here is the grand plan, implemented in tcUserStmt
 131
 132         What you type                   The IO [HValue] that hscStmt returns
 133         -------------                   ------------------------------------
 134         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 135                                         bindings: [x,y,...]
 136
 137         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 138                                         bindings: [x,y,...]
 139
 140         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 141           [NB: result not printed]      bindings: [it]
 142
 143
 144         expr (of non-IO type,
 145           result showable)      ==>     let v = expr in print v >> return [v]
 146                                         bindings: [it]
 147
 148         expr (of non-IO type,
 149           result not showable)  ==>     error
 150
 151
 152 \begin{code}
 153 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
 154
 155 tcUserStmt names (ExprStmt expr loc)
 156   = ASSERT( null names )
 157     tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
 158                 tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive),
 159                                ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc])
 160            (    traceTc (text "tcs 1a") `thenNF_Tc_`
 161                 tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc])
 162   where
 163     the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc
 164
 165 tcUserStmt names stmt
 166   = tc_stmts names [stmt]
 167
 168
 169 tc_stmts names stmts
 170   = tcLookupGlobalId returnIOName       `thenNF_Tc` \ return_id ->
 171     tcLookupGlobalId bindIOName         `thenNF_Tc` \ bind_id ->
 172     tcLookupGlobalId failIOName         `thenNF_Tc` \ fail_id ->
 173     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
 174     newTyVarTy liftedTypeKind           `thenNF_Tc` \ res_ty ->
 175     let
 176         io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
 177
 178                 -- mk_return builds the expression
 179                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 180         mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
 181                               (ExplicitListOut unitTy (map mk_item ids))
 182
 183         mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
 184                            (HsVar id)
 185     in
 186
 187     traceTc (text "tcs 2") `thenNF_Tc_`
 188     tcStmtsAndThen combine DoExpr io_ty stmts   (
 189         -- Look up the names right in the middle,
 190         -- where they will all be in scope
 191         mapNF_Tc tcLookupId names                       `thenNF_Tc` \ ids ->
 192         returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE)
 193     )                                                   `thenTc` \ ((ids, tc_stmts), lie) ->
 194
 195         -- Simplify the context right here, so that we fail
 196         -- if there aren't enough instances.  Notably, when we see
 197         --              e
 198         -- we use tryTc_ to try         it <- e
 199         -- and then                     let it = e
 200         -- It's the simplify step that rejects the first.
 201
 202     traceTc (text "tcs 3") `thenNF_Tc_`
 203     tcSimplifyTop lie                   `thenTc` \ const_binds ->
 204     traceTc (text "tcs 4") `thenNF_Tc_`
 205
 206     returnTc (mkHsLet const_binds $
 207               HsDoOut DoExpr tc_stmts return_id bind_id fail_id
 208                       (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
 209               ids)
 210   where
 211     combine stmt (ids, stmts) = (ids, stmt:stmts)
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 \subsection{Typechecking a module}
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222 typecheckModule
 223         :: DynFlags
 224         -> PersistentCompilerState
 225         -> HomeSymbolTable
 226         -> ModIface             -- Iface for this module
 227         -> PrintUnqualified     -- For error printing
 228         -> (SyntaxMap, [RenamedHsDecl])
 229         -> IO (Maybe (PersistentCompilerState, TcResults))
 230                         -- The new PCS is Augmented with imported information,
 231                                                 -- (but not stuff from this module)
 232
 233 data TcResults
 234   = TcResults {
 235         -- All these fields have info *just for this module*
 236         tc_env     :: TypeEnv,                  -- The top level TypeEnv
 237         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
 238         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
 239         tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
 240     }
 241
 242
 243 typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
 244   = do  { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
 245                              tcModule pcs hst get_fixity this_mod decls
 246         ; printTcDump dflags maybe_tc_result
 247         ; return maybe_tc_result }
 248   where
 249     this_mod   = mi_module   mod_iface
 250     fixity_env = mi_fixities mod_iface
 251
 252     get_fixity :: Name -> Maybe Fixity
 253     get_fixity nm = lookupNameEnv fixity_env nm
 254
 255
 256 tcModule :: PersistentCompilerState
 257          -> HomeSymbolTable
 258          -> (Name -> Maybe Fixity)
 259          -> Module
 260          -> [RenamedHsDecl]
 261          -> TcM (PersistentCompilerState, TcResults)
 262
 263 tcModule pcs hst get_fixity this_mod decls
 264   = fixTc (\ ~(unf_env, _, _) ->
 265                 -- Loop back the final environment, including the fully zonkec
 266                 -- versions of bindings from this module.  In the presence of mutual
 267                 -- recursion, interface type signatures may mention variables defined
 268                 -- in this module, which is why the knot is so big
 269
 270                 -- Type-check the type and class decls, and all imported decls
 271         tcImports unf_env pcs hst get_fixity this_mod decls
 272                                 `thenTc` \ (env, new_pcs, local_insts, deriv_binds, local_rules) ->
 273
 274         tcSetEnv env                            $
 275
 276         -- Foreign import declarations next
 277         traceTc (text "Tc4")                    `thenNF_Tc_`
 278         tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
 279         tcExtendGlobalValEnv fo_ids             $
 280
 281         -- Default declarations
 282         tcDefaults decls                        `thenTc` \ defaulting_tys ->
 283         tcSetDefaultTys defaulting_tys          $
 284
 285         -- Value declarations next.
 286         -- We also typecheck any extra binds that came out of the "deriving" process
 287         traceTc (text "Default types" <+> ppr defaulting_tys)   `thenNF_Tc_`
 288         traceTc (text "Tc5")                            `thenNF_Tc_`
 289         tcTopBinds (val_binds `ThenBinds` deriv_binds)  `thenTc` \ ((val_binds, env), lie_valdecls) ->
 290
 291         -- Second pass over class and instance declarations,
 292         -- plus rules and foreign exports, to generate bindings
 293         tcSetEnv env                            $
 294         tcInstDecls2  local_insts               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 295         tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 296         tcForeignExports decls                  `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
 297         tcSourceRules source_rules              `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
 298
 299              -- Deal with constant or ambiguous InstIds.  How could
 300              -- there be ambiguous ones?  They can only arise if a
 301              -- top-level decl falls under the monomorphism
 302              -- restriction, and no subsequent decl instantiates its
 303              -- type.  (Usually, ambiguous type variables are resolved
 304              -- during the generalisation step.)
 305         let
 306             lie_alldecls = lie_valdecls  `plusLIE`
 307                            lie_instdecls `plusLIE`
 308                            lie_clasdecls `plusLIE`
 309                            lie_fodecls   `plusLIE`
 310                            lie_rules
 311         in
 312         traceTc (text "Tc6")                            `thenNF_Tc_`
 313         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
 314
 315                 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
 316         tcCheckMain this_mod            `thenTc_`
 317
 318             -- Backsubstitution.    This must be done last.
 319             -- Even tcSimplifyTop may do some unification.
 320         let
 321             all_binds = val_binds               `AndMonoBinds`
 322                             inst_binds          `AndMonoBinds`
 323                             cls_dm_binds        `AndMonoBinds`
 324                             const_inst_binds    `AndMonoBinds`
 325                             foe_binds
 326         in
 327         traceTc (text "Tc7")            `thenNF_Tc_`
 328         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
 329         tcSetEnv final_env              $
 330                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 331         traceTc (text "Tc8")            `thenNF_Tc_`
 332         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 333         traceTc (text "Tc9")            `thenNF_Tc_`
 334         zonkRules more_local_rules      `thenNF_Tc` \ more_local_rules' ->
 335
 336
 337         let     local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
 338
 339                 -- Create any necessary "implicit" bindings (data constructors etc)
 340                 -- Should we create bindings for dictionary constructors?
 341                 -- They are always fully applied, and the bindings are just there
 342                 -- to support partial applications. But it's easier to let them through.
 343                 implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
 344                                                  | id <- implicitTyThingIds local_things
 345                                                  , let unf = idUnfolding id
 346                                                  , hasUnfolding unf
 347                                                  ]
 348
 349                 local_type_env :: TypeEnv
 350                 local_type_env = mkTypeEnv local_things
 351
 352                 all_local_rules = local_rules ++ more_local_rules'
 353         in
 354         traceTc (text "Tc10")           `thenNF_Tc_`
 355         returnTc (final_env,
 356                   new_pcs,
 357                   TcResults { tc_env     = local_type_env,
 358                               tc_binds   = implicit_binds `AndMonoBinds` all_binds',
 359                               tc_fords   = foi_decls ++ foe_decls',
 360                               tc_rules   = all_local_rules
 361                             }
 362         )
 363     )                   `thenTc` \ (_, pcs, tc_result) ->
 364     returnTc (pcs, tc_result)
 365   where
 366     tycl_decls   = [d | TyClD d <- decls]
 367     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 368     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
 369 \end{code}
 370
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsection{Typechecking interface decls}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 \begin{code}
 379 typecheckIface
 380         :: DynFlags
 381         -> PersistentCompilerState
 382         -> HomeSymbolTable
 383         -> ModIface             -- Iface for this module (just module & fixities)
 384         -> (SyntaxMap, [RenamedHsDecl])
 385         -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
 386                         -- The new PCS is Augmented with imported information,
 387                         -- (but not stuff from this module).
 388                         -- The TcResults returned contains only the environment
 389                         -- and rules.
 390
 391
 392 typecheckIface dflags pcs hst mod_iface (syn_map, decls)
 393   = do  { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
 394                             tcIfaceImports pcs hst get_fixity this_mod decls
 395         ; printIfaceDump dflags maybe_tc_stuff
 396         ; return maybe_tc_stuff }
 397   where
 398     this_mod   = mi_module   mod_iface
 399     fixity_env = mi_fixities mod_iface
 400
 401     get_fixity :: Name -> Maybe Fixity
 402     get_fixity nm = lookupNameEnv fixity_env nm
 403
 404     tcIfaceImports pcs hst get_fixity this_mod decls
 405         = fixTc (\ ~(unf_env, _, _, _, _) ->
 406               tcImports unf_env pcs hst get_fixity this_mod decls
 407           )     `thenTc` \ (env, new_pcs, local_inst_info,
 408                             deriv_binds, local_rules) ->
 409           ASSERT(nullBinds deriv_binds)
 410           let
 411               local_things = filter (isLocalThing this_mod)
 412                                         (nameEnvElts (getTcGEnv env))
 413               local_type_env :: TypeEnv
 414               local_type_env = mkTypeEnv local_things
 415           in
 416
 417           -- throw away local_inst_info
 418           returnTc (new_pcs, local_type_env, local_rules)
 419
 420
 421 tcImports :: RecTcEnv
 422           -> PersistentCompilerState
 423           -> HomeSymbolTable
 424           -> (Name -> Maybe Fixity)
 425           -> Module
 426           -> [RenamedHsDecl]
 427           -> TcM (TcEnv, PersistentCompilerState, [InstInfo],
 428                          RenamedHsBinds, [TypecheckedRuleDecl])
 429
 430 -- tcImports is a slight mis-nomer.
 431 -- It deals with everythign that could be an import:
 432 --      type and class decls
 433 --      interface signatures
 434 --      instance decls
 435 --      rule decls
 436 -- These can occur in source code too, of course
 437
 438 tcImports unf_env pcs hst get_fixity this_mod decls
 439           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 440           -- which is done lazily [ie failure just drops the pragma
 441           -- without having any global-failure effect].
 442           --
 443           -- unf_env is also used to get the pragama info
 444           -- for imported dfuns and default methods
 445
 446   = checkNoErrsTc $
 447         -- tcImports recovers internally, but if anything gave rise to
 448         -- an error we'd better stop now, to avoid a cascade
 449
 450     traceTc (text "Tc1")                        `thenNF_Tc_`
 451     tcTyAndClassDecls unf_env tycl_decls        `thenTc` \ env ->
 452     tcSetEnv env                                $
 453
 454         -- Typecheck the instance decls, includes deriving
 455     traceTc (text "Tc2")        `thenNF_Tc_`
 456     tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 457              hst unf_env get_fixity this_mod
 458              decls                      `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
 459     tcSetInstEnv inst_env                       $
 460
 461     -- Interface type signatures
 462     -- We tie a knot so that the Ids read out of interfaces are in scope
 463     --   when we read their pragmas.
 464     -- What we rely on is that pragmas are typechecked lazily; if
 465     --   any type errors are found (ie there's an inconsistency)
 466     --   we silently discard the pragma
 467     traceTc (text "Tc3")                        `thenNF_Tc_`
 468     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 469     tcExtendGlobalValEnv sig_ids                $
 470
 471
 472     tcIfaceRules (pcs_rules pcs) this_mod iface_rules   `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
 473         -- When relinking this module from its interface-file decls
 474         -- we'll have IfaceRules that are in fact local to this module
 475         -- That's the reason we we get any local_rules out here
 476
 477     tcGetEnv                                            `thenTc` \ unf_env ->
 478     let
 479         all_things = nameEnvElts (getTcGEnv unf_env)
 480
 481          -- sometimes we're compiling in the context of a package module
 482          -- (on the GHCi command line, for example).  In this case, we
 483          -- want to treat everything we pulled in as an imported thing.
 484         imported_things
 485           | isHomeModule this_mod
 486           = filter (not . isLocalThing this_mod) all_things
 487           | otherwise
 488           = all_things
 489
 490         new_pte :: PackageTypeEnv
 491         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 492
 493         new_pcs :: PersistentCompilerState
 494         new_pcs = pcs { pcs_PTE   = new_pte,
 495                         pcs_insts = new_pcs_insts,
 496                         pcs_rules = new_pcs_rules
 497                   }
 498     in
 499     returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
 500   where
 501     tycl_decls  = [d | TyClD d <- decls]
 502     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
 503 \end{code}
 504
 505
 506 %************************************************************************
 507 %*                                                                      *
 508 \subsection{Checking the type of main}
 509 %*                                                                      *
 510 %************************************************************************
 511
 512 We must check that in module Main,
 513         a) main is defined
 514         b) main :: forall a1...an. IO t,  for some type t
 515
 516 If we have
 517         main = error "Urk"
 518 then the type of main will be
 519         main :: forall a. a
 520 and that should pass the test too.
 521
 522 So we just instantiate the type and unify with IO t, and declare
 523 victory if doing so succeeds.
 524
 525 \begin{code}
 526 tcCheckMain :: Module -> TcM ()
 527 tcCheckMain this_mod
 528   | not (moduleName this_mod == mAIN_Name )
 529   = returnTc ()
 530
 531   | otherwise
 532   =     -- First unify the main_id with IO t, for any old t
 533     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
 534     case maybe_thing of
 535         Just (ATcId main_id) -> check_main_ty (idType main_id)
 536         other                -> addErrTc noMainErr
 537   where
 538     check_main_ty main_ty
 539       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
 540         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
 541         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
 542         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
 543         if not (null theta) then
 544                 failWithTc empty        -- Context has the error message
 545         else
 546         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
 547
 548 mainTypeCtxt main_ty tidy_env
 549   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
 550     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
 551                                  quotes (ppr (tidyType tidy_env main_ty')))
 552
 553 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 554                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
 555 \end{code}
 556
 557
 558 %************************************************************************
 559 %*                                                                      *
 560 \subsection{Interfacing the Tc monad to the IO monad}
 561 %*                                                                      *
 562 %************************************************************************
 563
 564 \begin{code}
 565 typecheck :: DynFlags
 566           -> SyntaxMap
 567           -> PersistentCompilerState
 568           -> HomeSymbolTable
 569           -> PrintUnqualified   -- For error printing
 570           -> TcM r
 571           -> IO (Maybe r)
 572
 573 typecheck dflags syn_map pcs hst unqual thing_inside
 574  = do   { showPass dflags "Typechecker";
 575         ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
 576
 577         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 578
 579         ; printErrorsAndWarnings unqual errs
 580
 581         ; if errorsFound errs then
 582              return Nothing
 583            else
 584              return maybe_tc_result
 585         }
 586 \end{code}
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection{Dumping output}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 \begin{code}
 596 printTcDump dflags Nothing = return ()
 597 printTcDump dflags (Just (_, results))
 598   = do dumpIfSet_dyn dflags Opt_D_dump_types
 599                      "Type signatures" (dump_sigs (tc_env results))
 600        dumpIfSet_dyn dflags Opt_D_dump_tc
 601                      "Typechecked" (dump_tc results)
 602
 603 printIfaceDump dflags Nothing = return ()
 604 printIfaceDump dflags (Just (_, env, rules))
 605   = do dumpIfSet_dyn dflags Opt_D_dump_types
 606                      "Type signatures" (dump_sigs env)
 607        dumpIfSet_dyn dflags Opt_D_dump_tc
 608                      "Typechecked" (dump_iface env rules)
 609
 610 dump_tc results
 611   = vcat [ppr (tc_binds results),
 612           pp_rules (tc_rules results),
 613           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 614     ]
 615
 616 dump_iface env rules
 617   = vcat [pp_rules rules,
 618           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
 619     ]
 620
 621 dump_sigs env   -- Print type signatures
 622   =     -- Convert to HsType so that we get source-language style printing
 623         -- And sort by RdrName
 624     vcat $ map ppr_sig $ sortLt lt_sig $
 625     [ (toRdrName id, toHsType (idType id))
 626     | AnId id <- nameEnvElts env,
 627       want_sig id
 628     ]
 629   where
 630     lt_sig (n1,_) (n2,_) = n1 < n2
 631     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 632
 633     want_sig id | opt_PprStyle_Debug = True
 634                 | otherwise          = isLocalId id && isGlobalName (idName id)
 635         -- isLocalId ignores data constructors, records selectors etc
 636         -- The isGlobalName ignores local dictionary and method bindings
 637         -- that the type checker has invented.  User-defined things have
 638         -- Global names.
 639
 640 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 641                            vcat (map ppr_gen_tycon tcs),
 642                            ptext SLIT("#-}")
 643                      ]
 644
 645 -- x&y are now Id's, not CoreExpr's
 646 ppr_gen_tycon tycon
 647   | Just ep <- tyConGenInfo tycon
 648   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 649
 650   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 651
 652 ppr_ep (EP from to)
 653   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 654            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 655            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 656     ]
 657   where
 658     (_,from_tau) = splitForAllTys (idType from)
 659
 660 pp_rules [] = empty
 661 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 662                     nest 4 (vcat (map ppr rs)),
 663                     ptext SLIT("#-}")]
 664 \end{code}