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