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