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