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