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