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 )
  15 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  16                           Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..),
  17                           isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
  18                         )
  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                           RenamedHsExpr )
  26 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
  27                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  28                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
  29                           zonkExpr, zonkIdBndr
  30                         )
  31
  32 import MkIface          ( pprModDetails )
  33 import TcExpr           ( tcMonoExpr )
  34 import TcMonad
  35 import TcType           ( newTyVarTy, zonkTcType, tcInstType )
  36 import TcMatches        ( tcStmtsAndThen )
  37 import TcUnify          ( unifyTauTy )
  38 import Inst             ( emptyLIE, plusLIE )
  39 import TcBinds          ( tcTopBinds )
  40 import TcClassDcl       ( tcClassDecls2 )
  41 import TcDefaults       ( tcDefaults, defaultDefaultTys )
  42 import TcEnv            ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
  43                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
  44                           tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon,
  45                           TcTyThing(..), tcLookupId
  46                         )
  47 import TcRules          ( tcIfaceRules, tcSourceRules )
  48 import TcForeign        ( tcForeignImports, tcForeignExports )
  49 import TcIfaceSig       ( tcInterfaceSigs )
  50 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  51 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
  52 import TcTyClsDecls     ( tcTyAndClassDecls )
  53
  54 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
  55 import TysWiredIn       ( mkListTy, unitTy )
  56 import Type
  57 import ErrUtils         ( printErrorsAndWarnings, errorsFound,
  58                           dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
  59 import Id               ( Id, idType, idUnfolding )
  60 import Module           ( Module, moduleName )
  61 import Name             ( Name )
  62 import NameEnv          ( nameEnvElts, lookupNameEnv )
  63 import TyCon            ( tyConGenInfo )
  64 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
  65 import SrcLoc           ( noSrcLoc )
  66 import Outputable
  67 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  68                           PackageTypeEnv, ModIface(..),
  69                           ModDetails(..), DFunId,
  70                           TypeEnv, extendTypeEnvList,
  71                           TyThing(..), implicitTyThingIds,
  72                           mkTypeEnv
  73                         )
  74 import VarSet
  75 \end{code}
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{The stmt interface}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 typecheckStmt
  86    :: DynFlags
  87    -> PersistentCompilerState
  88    -> HomeSymbolTable
  89    -> TypeEnv              -- The interactive context's type envt
  90    -> PrintUnqualified     -- For error printing
  91    -> Module               -- Is this really needed
  92    -> [Name]               -- Names bound by the Stmt (empty for expressions)
  93    -> (SyntaxMap,
  94        RenamedStmt,        -- The stmt itself
  95        [RenamedHsDecl])    -- Plus extra decls it sucked in from interface files
  96    -> IO (Maybe (PersistentCompilerState,
  97                  TypecheckedHsExpr,
  98                  [Id],
  99                  Type))
 100                 -- The returned [Id] is the same as the input except for
 101                 -- ExprStmt, in which case the returned [Name] is [itName]
 102
 103 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls)
 104   = typecheck dflags syn_map pcs hst unqual $
 105
 106          -- use the default default settings, i.e. [Integer, Double]
 107     tcSetDefaultTys defaultDefaultTys $
 108
 109         -- Typecheck the extra declarations
 110     fixTc (\ ~(unf_env, _, _, _, _) ->
 111         tcImports unf_env pcs hst get_fixity this_mod iface_decls
 112     )                   `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 113     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
 114
 115     tcSetEnv env                                $
 116     tcExtendGlobalTypeEnv ic_type_env           $
 117
 118         -- The real work is done here
 119     tcUserStmt names stmt               `thenTc` \ (expr, bound_ids) ->
 120
 121     traceTc (text "tcs 1") `thenNF_Tc_`
 122     zonkExpr expr                       `thenNF_Tc` \ zonked_expr ->
 123     mapNF_Tc zonkIdBndr bound_ids       `thenNF_Tc` \ zonked_ids ->
 124
 125     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
 126     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr))         `thenNF_Tc_`
 127
 128     returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
 129
 130   where
 131     get_fixity :: Name -> Maybe Fixity
 132     get_fixity n = pprPanic "typecheckStmt" (ppr n)
 133 \end{code}
 134
 135 Here is the grand plan, implemented in tcUserStmt
 136
 137         What you type                   The IO [HValue] that hscStmt returns
 138         -------------                   ------------------------------------
 139         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 140                                         bindings: [x,y,...]
 141
 142         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 143                                         bindings: [x,y,...]
 144
 145         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 146           [NB: result not printed]      bindings: [it]
 147
 148
 149         expr (of non-IO type,
 150           result showable)      ==>     let v = expr in print v >> return [v]
 151                                         bindings: [it]
 152
 153         expr (of non-IO type,
 154           result not showable)  ==>     error
 155
 156
 157 \begin{code}
 158 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
 159
 160 tcUserStmt names (ExprStmt expr loc)
 161   = ASSERT( null names )
 162     tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
 163                 tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive),
 164                                ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc])
 165            (    traceTc (text "tcs 1a") `thenNF_Tc_`
 166                 tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc])
 167   where
 168     the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc
 169
 170 tcUserStmt names stmt
 171   = tc_stmts names [stmt]
 172
 173
 174 tc_stmts names stmts
 175   = tcLookupGlobalId returnIOName       `thenNF_Tc` \ return_id ->
 176     tcLookupGlobalId bindIOName         `thenNF_Tc` \ bind_id ->
 177     tcLookupGlobalId failIOName         `thenNF_Tc` \ fail_id ->
 178     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
 179     newTyVarTy liftedTypeKind           `thenNF_Tc` \ res_ty ->
 180     let
 181         io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
 182
 183                 -- mk_return builds the expression
 184                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 185         mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
 186                               (ExplicitListOut unitTy (map mk_item ids))
 187
 188         mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
 189                            (HsVar id)
 190     in
 191
 192     traceTc (text "tcs 2") `thenNF_Tc_`
 193     tcStmtsAndThen combine DoExpr io_ty stmts   (
 194         -- Look up the names right in the middle,
 195         -- where they will all be in scope
 196         mapNF_Tc tcLookupId names                       `thenNF_Tc` \ ids ->
 197         returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE)
 198     )                                                   `thenTc` \ ((ids, tc_stmts), lie) ->
 199
 200         -- Simplify the context right here, so that we fail
 201         -- if there aren't enough instances.  Notably, when we see
 202         --              e
 203         -- we use tryTc_ to try         it <- e
 204         -- and then                     let it = e
 205         -- It's the simplify step that rejects the first.
 206
 207     traceTc (text "tcs 3") `thenNF_Tc_`
 208     tcSimplifyTop lie                   `thenTc` \ const_binds ->
 209     traceTc (text "tcs 4") `thenNF_Tc_`
 210
 211     returnTc (mkHsLet const_binds $
 212               HsDoOut DoExpr tc_stmts return_id bind_id fail_id
 213                       (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
 214               ids)
 215   where
 216     combine stmt (ids, stmts) = (ids, stmt:stmts)
 217 \end{code}
 218
 219 %************************************************************************
 220 %*                                                                      *
 221 \subsection{Typechecking an expression}
 222 %*                                                                      *
 223 %************************************************************************
 224
 225 \begin{code}
 226 typecheckExpr :: DynFlags
 227               -> PersistentCompilerState
 228               -> HomeSymbolTable
 229               -> TypeEnv           -- The interactive context's type envt
 230               -> PrintUnqualified       -- For error printing
 231               -> Module
 232               -> (SyntaxMap,
 233                   RenamedHsExpr,        -- The expression itself
 234                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
 235               -> IO (Maybe (PersistentCompilerState,
 236                             TypecheckedHsExpr,
 237                             [Id],       -- always empty (matches typecheckStmt)
 238                             Type))
 239
 240 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls)
 241   = typecheck dflags syn_map pcs hst unqual $
 242
 243          -- use the default default settings, i.e. [Integer, Double]
 244     tcSetDefaultTys defaultDefaultTys $
 245
 246         -- Typecheck the extra declarations
 247     fixTc (\ ~(unf_env, _, _, _, _) ->
 248         tcImports unf_env pcs hst get_fixity this_mod decls
 249     )                   `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 250     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
 251
 252         -- Now typecheck the expression
 253     tcSetEnv env                        $
 254     tcExtendGlobalTypeEnv ic_type_env   $
 255
 256     newTyVarTy openTypeKind             `thenTc` \ ty ->
 257     tcMonoExpr expr ty                  `thenTc` \ (e', lie) ->
 258     tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie
 259                         `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
 260     tcSimplifyTop lie_free              `thenTc` \ const_binds ->
 261
 262     let all_expr = mkHsLet const_binds  $
 263                    TyLam qtvs           $
 264                    DictLam dict_ids     $
 265                    mkHsLet dict_binds   $
 266                    e'
 267
 268         all_expr_ty = mkForAllTys qtvs  $
 269                       mkFunTys (map idType dict_ids) $
 270                       ty
 271     in
 272
 273     zonkExpr all_expr                           `thenNF_Tc` \ zonked_expr ->
 274     zonkTcType all_expr_ty                      `thenNF_Tc` \ zonked_ty ->
 275     ioToTc (dumpIfSet_dyn dflags
 276                 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
 277     returnTc (new_pcs, zonked_expr, [], zonked_ty)
 278
 279   where
 280     get_fixity :: Name -> Maybe Fixity
 281     get_fixity n = pprPanic "typecheckExpr" (ppr n)
 282
 283     smpl_doc = ptext SLIT("main expression")
 284 \end{code}
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsection{Typechecking a module}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 typecheckModule
 294         :: DynFlags
 295         -> PersistentCompilerState
 296         -> HomeSymbolTable
 297         -> ModIface             -- Iface for this module
 298         -> PrintUnqualified     -- For error printing
 299         -> (SyntaxMap, [RenamedHsDecl])
 300         -> IO (Maybe (PersistentCompilerState, TcResults))
 301                         -- The new PCS is Augmented with imported information,
 302                                                 -- (but not stuff from this module)
 303
 304 data TcResults
 305   = TcResults {
 306         -- All these fields have info *just for this module*
 307         tc_env     :: TypeEnv,                  -- The top level TypeEnv
 308         tc_insts   :: [DFunId],                 -- Instances
 309         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
 310         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
 311         tc_fords   :: [TypecheckedForeignDecl]  -- Foreign import & exports.
 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_insts   = map iDFunId local_insts,
 431                               tc_binds   = implicit_binds `AndMonoBinds` all_binds',
 432                               tc_fords   = foi_decls ++ foe_decls',
 433                               tc_rules   = all_local_rules
 434                             }
 435         )
 436     )                   `thenTc` \ (_, pcs, tc_result) ->
 437     returnTc (pcs, tc_result)
 438   where
 439     tycl_decls   = [d | TyClD d <- decls]
 440     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 441     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
 442 \end{code}
 443
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection{Typechecking interface decls}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 \begin{code}
 452 typecheckIface
 453         :: DynFlags
 454         -> PersistentCompilerState
 455         -> HomeSymbolTable
 456         -> ModIface             -- Iface for this module (just module & fixities)
 457         -> (SyntaxMap, [RenamedHsDecl])
 458         -> IO (Maybe (PersistentCompilerState, ModDetails))
 459                         -- The new PCS is Augmented with imported information,
 460                         -- (but not stuff from this module).
 461
 462 typecheckIface dflags pcs hst mod_iface (syn_map, decls)
 463   = do  { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
 464                             tcIfaceImports pcs hst get_fixity this_mod decls
 465         ; printIfaceDump dflags maybe_tc_stuff
 466         ; return maybe_tc_stuff }
 467   where
 468     this_mod   = mi_module   mod_iface
 469     fixity_env = mi_fixities mod_iface
 470
 471     get_fixity :: Name -> Maybe Fixity
 472     get_fixity nm = lookupNameEnv fixity_env nm
 473
 474     tcIfaceImports pcs hst get_fixity this_mod decls
 475         = fixTc (\ ~(unf_env, _, _, _, _) ->
 476               tcImports unf_env pcs hst get_fixity this_mod decls
 477           )     `thenTc` \ (env, new_pcs, local_inst_info,
 478                             deriv_binds, local_rules) ->
 479           ASSERT(nullBinds deriv_binds)
 480           let
 481               local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
 482
 483               mod_details = ModDetails { md_types = mkTypeEnv local_things,
 484                                          md_insts = map iDFunId local_inst_info,
 485                                          md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules] }
 486                         -- All the rules from an interface are of the IfaceRuleOut form
 487           in
 488           returnTc (new_pcs, mod_details)
 489
 490 tcImports :: RecTcEnv
 491           -> PersistentCompilerState
 492           -> HomeSymbolTable
 493           -> (Name -> Maybe Fixity)
 494           -> Module
 495           -> [RenamedHsDecl]
 496           -> TcM (TcEnv, PersistentCompilerState, [InstInfo],
 497                          RenamedHsBinds, [TypecheckedRuleDecl])
 498
 499 -- tcImports is a slight mis-nomer.
 500 -- It deals with everything that could be an import:
 501 --      type and class decls
 502 --      interface signatures (checked lazily)
 503 --      instance decls
 504 --      rule decls
 505 -- These can occur in source code too, of course
 506
 507 tcImports unf_env pcs hst get_fixity this_mod decls
 508           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 509           -- which is done lazily [ie failure just drops the pragma
 510           -- without having any global-failure effect].
 511           --
 512           -- unf_env is also used to get the pragama info
 513           -- for imported dfuns and default methods
 514
 515   = checkNoErrsTc $
 516         -- tcImports recovers internally, but if anything gave rise to
 517         -- an error we'd better stop now, to avoid a cascade
 518
 519     traceTc (text "Tc1")                        `thenNF_Tc_`
 520     tcTyAndClassDecls unf_env tycl_decls        `thenTc` \ env ->
 521     tcSetEnv env                                $
 522
 523         -- Typecheck the instance decls, includes deriving
 524     traceTc (text "Tc2")        `thenNF_Tc_`
 525     tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 526              hst unf_env get_fixity this_mod
 527              decls                      `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
 528     tcSetInstEnv inst_env                       $
 529
 530     -- Interface type signatures
 531     -- We tie a knot so that the Ids read out of interfaces are in scope
 532     --   when we read their pragmas.
 533     -- What we rely on is that pragmas are typechecked lazily; if
 534     --   any type errors are found (ie there's an inconsistency)
 535     --   we silently discard the pragma
 536     traceTc (text "Tc3")                        `thenNF_Tc_`
 537     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 538     tcExtendGlobalValEnv sig_ids                $
 539
 540
 541     tcIfaceRules (pcs_rules pcs) this_mod iface_rules   `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
 542         -- When relinking this module from its interface-file decls
 543         -- we'll have IfaceRules that are in fact local to this module
 544         -- That's the reason we we get any local_rules out here
 545
 546     tcGetEnv                                            `thenTc` \ unf_env ->
 547     let
 548         all_things = nameEnvElts (getTcGEnv unf_env)
 549
 550          -- sometimes we're compiling in the context of a package module
 551          -- (on the GHCi command line, for example).  In this case, we
 552          -- want to treat everything we pulled in as an imported thing.
 553         imported_things
 554           = filter (not . isLocalThing this_mod) all_things
 555
 556         new_pte :: PackageTypeEnv
 557         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 558
 559         new_pcs :: PersistentCompilerState
 560         new_pcs = pcs { pcs_PTE   = new_pte,
 561                         pcs_insts = new_pcs_insts,
 562                         pcs_rules = new_pcs_rules
 563                   }
 564     in
 565     returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
 566   where
 567     tycl_decls  = [d | TyClD d <- decls]
 568     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
 569 \end{code}
 570
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection{Checking the type of main}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 We must check that in module Main,
 579         a) main is defined
 580         b) main :: forall a1...an. IO t,  for some type t
 581
 582 If we have
 583         main = error "Urk"
 584 then the type of main will be
 585         main :: forall a. a
 586 and that should pass the test too.
 587
 588 So we just instantiate the type and unify with IO t, and declare
 589 victory if doing so succeeds.
 590
 591 \begin{code}
 592 tcCheckMain :: Module -> TcM ()
 593 tcCheckMain this_mod
 594   | not (moduleName this_mod == mAIN_Name )
 595   = returnTc ()
 596
 597   | otherwise
 598   =     -- First unify the main_id with IO t, for any old t
 599     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
 600     case maybe_thing of
 601         Just (ATcId main_id) -> check_main_ty (idType main_id)
 602         other                -> addErrTc noMainErr
 603   where
 604     check_main_ty main_ty
 605       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
 606         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
 607         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
 608         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
 609         if not (null theta) then
 610                 failWithTc empty        -- Context has the error message
 611         else
 612         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
 613
 614 mainTypeCtxt main_ty tidy_env
 615   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
 616     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
 617                                  quotes (ppr (tidyType tidy_env main_ty')))
 618
 619 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 620                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
 621 \end{code}
 622
 623
 624 %************************************************************************
 625 %*                                                                      *
 626 \subsection{Interfacing the Tc monad to the IO monad}
 627 %*                                                                      *
 628 %************************************************************************
 629
 630 \begin{code}
 631 typecheck :: DynFlags
 632           -> SyntaxMap
 633           -> PersistentCompilerState
 634           -> HomeSymbolTable
 635           -> PrintUnqualified   -- For error printing
 636           -> TcM r
 637           -> IO (Maybe r)
 638
 639 typecheck dflags syn_map pcs hst unqual thing_inside
 640  = do   { showPass dflags "Typechecker";
 641         ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
 642
 643         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 644
 645         ; printErrorsAndWarnings unqual errs
 646
 647         ; if errorsFound errs then
 648              return Nothing
 649            else
 650              return maybe_tc_result
 651         }
 652 \end{code}
 653
 654
 655 %************************************************************************
 656 %*                                                                      *
 657 \subsection{Dumping output}
 658 %*                                                                      *
 659 %************************************************************************
 660
 661 \begin{code}
 662 printTcDump dflags Nothing = return ()
 663 printTcDump dflags (Just (_, results))
 664   = do dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 665                      "Interface" (dump_tc_iface results)
 666
 667        dumpIfSet_dyn dflags Opt_D_dump_tc
 668                      "Typechecked" (ppr (tc_binds results))
 669
 670
 671 printIfaceDump dflags Nothing = return ()
 672 printIfaceDump dflags (Just (_, details))
 673   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 674                      "Interface" (pprModDetails details)
 675
 676 dump_tc_iface results
 677   = vcat [pprModDetails (ModDetails {md_types = tc_env results,
 678                                      md_insts = tc_insts results,
 679                                      md_rules = []}) ,
 680           ppr_rules (tc_rules results),
 681
 682           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 683     ]
 684
 685 ppr_rules [] = empty
 686 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
 687                       nest 4 (vcat (map ppr rs)),
 688                       ptext SLIT("#-}")]
 689
 690 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 691                            vcat (map ppr_gen_tycon tcs),
 692                            ptext SLIT("#-}")
 693                      ]
 694
 695 -- x&y are now Id's, not CoreExpr's
 696 ppr_gen_tycon tycon
 697   | Just ep <- tyConGenInfo tycon
 698   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 699
 700   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 701
 702 ppr_ep (EP from to)
 703   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 704            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 705            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 706     ]
 707   where
 708     (_,from_tau) = splitForAllTys (idType from)
 709
 710 \end{code}