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