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