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