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