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, initInstEnv, 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 hst 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 hst 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 hst this_mod decls  `thenTc` \ (new_pcs, _) ->
 300    returnTc new_pcs
 301
 302 tcExtraDecls :: PersistentCompilerState
 303              -> HomeSymbolTable
 304              -> Module
 305              -> [RenamedHsDecl]
 306              -> TcM (PersistentCompilerState, TcEnv)
 307         -- Returned environment includes instances
 308
 309 tcExtraDecls pcs hst this_mod decls
 310   = tcIfaceImports this_mod decls       `thenTc` \ (env, all_things, dfuns, rules) ->
 311     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 312     let
 313         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) all_things
 314         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 315
 316         new_pcs :: PersistentCompilerState
 317         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 318                         pcs_insts = new_pcs_insts,
 319                         pcs_rules = new_pcs_rules
 320                   }
 321     in
 322         -- Initialise the instance environment
 323     tcSetEnv env (
 324         initInstEnv new_pcs hst         `thenNF_Tc` \ inst_env ->
 325         tcSetInstEnv inst_env tcGetEnv
 326     )                                   `thenNF_Tc` \ new_env ->
 327     returnTc (new_pcs, new_env)
 328 \end{code}
 329
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection{Typechecking a module}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 \begin{code}
 338 typecheckModule
 339         :: DynFlags
 340         -> PersistentCompilerState
 341         -> HomeSymbolTable
 342         -> ModIface             -- Iface for this module
 343         -> PrintUnqualified     -- For error printing
 344         -> [RenamedHsDecl]
 345         -> IO (Maybe (PersistentCompilerState, TcResults))
 346                         -- The new PCS is Augmented with imported information,
 347                                                 -- (but not stuff from this module)
 348
 349 data TcResults
 350   = TcResults {
 351         -- All these fields have info *just for this module*
 352         tc_env     :: TypeEnv,                  -- The top level TypeEnv
 353         tc_insts   :: [DFunId],                 -- Instances
 354         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
 355         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
 356         tc_fords   :: [TypecheckedForeignDecl]  -- Foreign import & exports.
 357     }
 358
 359
 360 typecheckModule dflags pcs hst mod_iface unqual decls
 361   = do  { maybe_tc_result <- typecheck dflags pcs hst unqual $
 362                              tcModule pcs hst get_fixity this_mod decls
 363         ; printTcDump dflags unqual maybe_tc_result
 364         ; return maybe_tc_result }
 365   where
 366     this_mod   = mi_module   mod_iface
 367     fixity_env = mi_fixities mod_iface
 368
 369     get_fixity :: Name -> Maybe Fixity
 370     get_fixity nm = lookupNameEnv fixity_env nm
 371
 372
 373 tcModule :: PersistentCompilerState
 374          -> HomeSymbolTable
 375          -> (Name -> Maybe Fixity)
 376          -> Module
 377          -> [RenamedHsDecl]
 378          -> TcM (PersistentCompilerState, TcResults)
 379
 380 tcModule pcs hst get_fixity this_mod decls
 381   = fixTc (\ ~(unf_env, _, _) ->
 382                 -- Loop back the final environment, including the fully zonked
 383                 -- versions of bindings from this module.  In the presence of mutual
 384                 -- recursion, interface type signatures may mention variables defined
 385                 -- in this module, which is why the knot is so big
 386
 387                 -- Type-check the type and class decls, and all imported decls
 388         tcImports unf_env pcs hst get_fixity this_mod
 389                   tycl_decls iface_inst_decls iface_rule_decls     `thenTc` \ (env1, new_pcs) ->
 390
 391         tcSetEnv env1                           $
 392
 393                 -- Do the source-language instances, including derivings
 394         initInstEnv new_pcs hst                 `thenNF_Tc` \ inst_env1 ->
 395         tcInstDecls1 (pcs_PRS new_pcs) inst_env1
 396                      get_fixity this_mod
 397                      tycl_decls src_inst_decls  `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
 398         tcSetInstEnv inst_env2                  $
 399
 400         -- Foreign import declarations next
 401         traceTc (text "Tc4")                    `thenNF_Tc_`
 402         tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
 403         tcExtendGlobalValEnv fo_ids             $
 404
 405         -- Default declarations
 406         tcDefaults decls                        `thenTc` \ defaulting_tys ->
 407         tcSetDefaultTys defaulting_tys          $
 408
 409         -- Value declarations next.
 410         -- We also typecheck any extra binds that came out of the "deriving" process
 411         traceTc (text "Default types" <+> ppr defaulting_tys)   `thenNF_Tc_`
 412         traceTc (text "Tc5")                            `thenNF_Tc_`
 413         tcTopBinds (val_binds `ThenBinds` deriv_binds)  `thenTc` \ ((val_binds, env2), lie_valdecls) ->
 414
 415         -- Second pass over class and instance declarations,
 416         -- plus rules and foreign exports, to generate bindings
 417         tcSetEnv env2                           $
 418         traceTc (text "Tc6")                    `thenNF_Tc_`
 419         traceTc (ppr (getTcGEnv env2))          `thenNF_Tc_`
 420         tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
 421         tcExtendGlobalValEnv dm_ids             $
 422         traceTc (text "Tc7")                    `thenNF_Tc_`
 423         tcInstDecls2 inst_info                  `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 424         traceTc (text "Tc8")                    `thenNF_Tc_`
 425         tcForeignExports decls                  `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
 426         traceTc (text "Tc9")                    `thenNF_Tc_`
 427         tcSourceRules src_rule_decls            `thenNF_Tc` \ (lie_rules,     src_rules) ->
 428
 429                 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
 430         traceTc (text "Tc10")                   `thenNF_Tc_`
 431         tcCheckMain this_mod                    `thenTc_`
 432
 433              -- Deal with constant or ambiguous InstIds.  How could
 434              -- there be ambiguous ones?  They can only arise if a
 435              -- top-level decl falls under the monomorphism
 436              -- restriction, and no subsequent decl instantiates its
 437              -- type.  (Usually, ambiguous type variables are resolved
 438              -- during the generalisation step.)
 439              --
 440              -- Note that we must do this *after* tcCheckMain, because of the
 441              -- following bizarre case:
 442              --         main = return ()
 443              -- Here, we infer main :: forall a. m a, where m is a free
 444              -- type variable.  tcCheckMain will unify it with IO, and that
 445              -- must happen before tcSimplifyTop, since the latter will report
 446              -- m as ambiguous
 447         let
 448             lie_alldecls = lie_valdecls  `plusLIE`
 449                            lie_instdecls `plusLIE`
 450                            lie_clasdecls `plusLIE`
 451                            lie_fodecls   `plusLIE`
 452                            lie_rules
 453         in
 454         tcSimplifyTop lie_alldecls      `thenTc` \ const_inst_binds ->
 455         traceTc (text "endsimpltop") `thenTc_`
 456
 457             -- Backsubstitution.    This must be done last.
 458             -- Even tcSimplifyTop may do some unification.
 459         let
 460             all_binds = val_binds               `AndMonoBinds`
 461                             inst_binds          `AndMonoBinds`
 462                             cls_dm_binds        `AndMonoBinds`
 463                             const_inst_binds    `AndMonoBinds`
 464                             foe_binds
 465         in
 466         traceTc (text "Tc7")            `thenNF_Tc_`
 467         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
 468         tcSetEnv final_env              $
 469                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 470         traceTc (text "Tc8")            `thenNF_Tc_`
 471         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 472         traceTc (text "Tc9")            `thenNF_Tc_`
 473         zonkRules src_rules             `thenNF_Tc` \ src_rules' ->
 474
 475
 476         let     src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
 477                                 -- This is horribly crude; the env might be jolly big
 478         in
 479         traceTc (text "Tc10")           `thenNF_Tc_`
 480         returnTc (final_env,
 481                   new_pcs,
 482                   TcResults { tc_env     = mkTypeEnv src_things,
 483                               tc_insts   = map iDFunId inst_info,
 484                               tc_binds   = all_binds',
 485                               tc_fords   = foi_decls ++ foe_decls',
 486                               tc_rules   = src_rules'
 487                             }
 488         )
 489     )                   `thenTc` \ (_, pcs, tc_result) ->
 490     returnTc (pcs, tc_result)
 491   where
 492     tycl_decls = [d | TyClD d <- decls]
 493     rule_decls = [d | RuleD d <- decls]
 494     inst_decls = [d | InstD d <- decls]
 495     val_decls  = [d | ValD d  <- decls]
 496
 497     (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl            inst_decls
 498     (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
 499     val_binds                          = foldr ThenBinds EmptyBinds val_decls
 500 \end{code}
 501
 502
 503 %************************************************************************
 504 %*                                                                      *
 505 \subsection{Typechecking interface decls}
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 \begin{code}
 510 typecheckIface
 511         :: DynFlags
 512         -> PersistentCompilerState
 513         -> HomeSymbolTable
 514         -> ModIface             -- Iface for this module (just module & fixities)
 515         -> [RenamedHsDecl]
 516         -> IO (Maybe (PersistentCompilerState, ModDetails))
 517                         -- The new PCS is Augmented with imported information,
 518                         -- (but not stuff from this module).
 519
 520 typecheckIface dflags pcs hst mod_iface decls
 521   = do  { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
 522                             tcIface pcs this_mod decls
 523         ; printIfaceDump dflags maybe_tc_stuff
 524         ; return maybe_tc_stuff }
 525   where
 526     this_mod = mi_module mod_iface
 527
 528 tcIface pcs this_mod decls
 529 -- The decls are coming from this_mod's interface file, together
 530 -- with imported interface decls that belong in the "package" stuff.
 531 -- (With GHCi, all the home modules have already been processed.)
 532 -- That is why we need to do the partitioning below.
 533   = tcIfaceImports this_mod decls       `thenTc` \ (_, all_things, dfuns, rules) ->
 534
 535     let
 536         -- Do the partitioning (see notes above)
 537         (local_things, imported_things) = partition (isLocalThing this_mod) all_things
 538         (local_rules,  imported_rules)  = partition is_local_rule rules
 539         (local_dfuns,  imported_dfuns)  = partition (isLocalThing this_mod) dfuns
 540         is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
 541     in
 542     addInstDFuns (pcs_insts pcs) imported_dfuns         `thenNF_Tc` \ new_pcs_insts ->
 543     let
 544         new_pcs_pte :: PackageTypeEnv
 545         new_pcs_pte   = extendTypeEnvList (pcs_PTE pcs) imported_things
 546         new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
 547
 548         new_pcs :: PersistentCompilerState
 549         new_pcs = pcs { pcs_PTE   = new_pcs_pte,
 550                         pcs_insts = new_pcs_insts,
 551                         pcs_rules = new_pcs_rules
 552                   }
 553
 554         mod_details = ModDetails { md_types = mkTypeEnv local_things,
 555                                    md_insts = local_dfuns,
 556                                    md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
 557                                    md_binds = [] }
 558                         -- All the rules from an interface are of the IfaceRuleOut form
 559     in
 560     returnTc (new_pcs, mod_details)
 561
 562
 563 tcIfaceImports :: Module
 564                -> [RenamedHsDecl]       -- All interface-file decls
 565                -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
 566 tcIfaceImports this_mod decls
 567 -- The decls are all interface-file declarations
 568   = let
 569         inst_decls = [d | InstD d <- decls]
 570         tycl_decls = [d | TyClD d <- decls]
 571         rule_decls = [d | RuleD d <- decls]
 572     in
 573     fixTc (\ ~(unf_env, _, _, _) ->
 574         -- This fixTc follows the same general plan as tcImports,
 575         -- which is better commented (below)
 576         tcTyAndClassDecls unf_env this_mod tycl_decls   `thenTc` \ tycl_things ->
 577         tcExtendGlobalEnv tycl_things                   $
 578         tcInterfaceSigs unf_env this_mod tycl_decls     `thenTc` \ sig_ids ->
 579         tcExtendGlobalValEnv sig_ids                    $
 580         tcIfaceInstDecls1 inst_decls                    `thenTc` \ dfuns ->
 581         tcIfaceRules rule_decls                         `thenTc` \ rules ->
 582         tcGetEnv                                        `thenTc` \ env ->
 583         let
 584           all_things = map AnId sig_ids ++ tycl_things
 585         in
 586         returnTc (env, all_things, dfuns, rules)
 587     )
 588
 589
 590 tcImports :: RecTcEnv
 591           -> PersistentCompilerState
 592           -> HomeSymbolTable
 593           -> (Name -> Maybe Fixity)
 594           -> Module
 595           -> [RenamedTyClDecl]
 596           -> [RenamedInstDecl]
 597           -> [RenamedRuleDecl]
 598           -> TcM (TcEnv, PersistentCompilerState)
 599
 600 -- tcImports is a slight mis-nomer.
 601 -- It deals with everything that could be an import:
 602 --      type and class decls (some source, some imported)
 603 --      interface signatures (checked lazily)
 604 --      instance decls (some source, some imported)
 605 --      rule decls (all imported)
 606 -- These can occur in source code too, of course
 607 --
 608 -- tcImports is only called when processing source code,
 609 -- so that any interface-file declarations are for other modules, not this one
 610
 611 tcImports unf_env pcs hst get_fixity this_mod
 612           tycl_decls inst_decls rule_decls
 613           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 614           -- which is done lazily [ie failure just drops the pragma
 615           -- without having any global-failure effect].
 616           --
 617           -- unf_env is also used to get the pragama info
 618           -- for imported dfuns and default methods
 619
 620   = checkNoErrsTc $
 621         -- tcImports recovers internally, but if anything gave rise to
 622         -- an error we'd better stop now, to avoid a cascade
 623
 624     traceTc (text "Tc1")                                `thenNF_Tc_`
 625     tcTyAndClassDecls unf_env this_mod tycl_decls       `thenTc` \ tycl_things ->
 626     tcExtendGlobalEnv tycl_things                       $
 627
 628         -- Interface type signatures
 629         -- We tie a knot so that the Ids read out of interfaces are in scope
 630         --   when we read their pragmas.
 631         -- What we rely on is that pragmas are typechecked lazily; if
 632         --   any type errors are found (ie there's an inconsistency)
 633         --   we silently discard the pragma
 634     traceTc (text "Tc2")                        `thenNF_Tc_`
 635     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
 636     tcExtendGlobalValEnv sig_ids                $
 637
 638         -- Typecheck the instance decls, includes deriving
 639         -- Note that imported dictionary functions are already
 640         -- in scope from the preceding tcInterfaceSigs
 641     traceTc (text "Tc3")                `thenNF_Tc_`
 642     tcIfaceInstDecls1 inst_decls        `thenTc` \ dfuns ->
 643     tcIfaceRules rule_decls             `thenNF_Tc` \ rules ->
 644
 645     addInstDFuns (pcs_insts pcs) dfuns  `thenNF_Tc` \ new_pcs_insts ->
 646     tcGetEnv                            `thenTc` \ unf_env ->
 647     let
 648          -- sometimes we're compiling in the context of a package module
 649          -- (on the GHCi command line, for example).  In this case, we
 650          -- want to treat everything we pulled in as an imported thing.
 651         imported_things = map AnId sig_ids ++   -- All imported
 652                           filter (not . isLocalThing this_mod) tycl_things
 653
 654         new_pte :: PackageTypeEnv
 655         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 656
 657         new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
 658
 659         new_pcs :: PersistentCompilerState
 660         new_pcs = pcs { pcs_PTE   = new_pte,
 661                         pcs_insts = new_pcs_insts,
 662                         pcs_rules = new_pcs_rules
 663                   }
 664     in
 665     returnTc (unf_env, new_pcs)
 666
 667 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
 668 -- This is a bit gruesome.
 669 -- Usually, HsRules come only from source files; IfaceRules only from interface files
 670 -- But built-in rules appear as an IfaceRuleOut... and when compiling
 671 -- the source file for that built-in rule, we want to treat it as a source
 672 -- rule, so it gets put with the other rules for that module.
 673 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _)       = True
 674 isSourceRuleDecl this_mod (IfaceRule  _ _ _ n _ _ _) = False
 675 isSourceRuleDecl this_mod (IfaceRuleOut name _)      = isLocalThing this_mod name
 676
 677 addIfaceRules rule_base rules
 678   = foldl add_rule rule_base rules
 679   where
 680     add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
 681 \end{code}
 682
 683
 684 %************************************************************************
 685 %*                                                                      *
 686 \subsection{Checking the type of main}
 687 %*                                                                      *
 688 %************************************************************************
 689
 690 We must check that in module Main,
 691         a) main is defined
 692         b) main :: forall a1...an. IO t,  for some type t
 693
 694 If we have
 695         main = error "Urk"
 696 then the type of main will be
 697         main :: forall a. a
 698 and that should pass the test too.
 699
 700 So we just instantiate the type and unify with IO t, and declare
 701 victory if doing so succeeds.
 702
 703 \begin{code}
 704 tcCheckMain :: Module -> TcM ()
 705 tcCheckMain this_mod
 706   | not (moduleName this_mod == mAIN_Name )
 707   = returnTc ()
 708
 709   | otherwise
 710   =     -- First unify the main_id with IO t, for any old t
 711     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
 712     case maybe_thing of
 713         Just (ATcId main_id) -> check_main_ty (idType main_id)
 714         other                -> addErrTc noMainErr
 715   where
 716     check_main_ty main_ty
 717       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
 718         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
 719         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
 720         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
 721         if not (null theta) then
 722                 failWithTc empty        -- Context has the error message
 723         else
 724         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
 725
 726 mainTypeCtxt main_ty tidy_env
 727   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
 728     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
 729                                  quotes (ppr (tidyType tidy_env main_ty')))
 730
 731 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 732                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
 733 \end{code}
 734
 735
 736 %************************************************************************
 737 %*                                                                      *
 738 \subsection{Interfacing the Tc monad to the IO monad}
 739 %*                                                                      *
 740 %************************************************************************
 741
 742 \begin{code}
 743 typecheck :: DynFlags
 744           -> PersistentCompilerState
 745           -> HomeSymbolTable
 746           -> PrintUnqualified   -- For error printing
 747           -> TcM r
 748           -> IO (Maybe r)
 749
 750 typecheck dflags pcs hst unqual thing_inside
 751  = do   { showPass dflags "Typechecker";
 752         ; env <- initTcEnv hst (pcs_PTE pcs)
 753
 754         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 755
 756         ; printErrorsAndWarnings unqual errs
 757
 758         ; if errorsFound errs then
 759              return Nothing
 760            else
 761              return maybe_tc_result
 762         }
 763 \end{code}
 764
 765
 766 %************************************************************************
 767 %*                                                                      *
 768 \subsection{Dumping output}
 769 %*                                                                      *
 770 %************************************************************************
 771
 772 \begin{code}
 773 printTcDump dflags unqual Nothing = return ()
 774 printTcDump dflags unqual (Just (_, results))
 775   = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
 776           printForUser stdout unqual (dump_tc_iface dflags results)
 777           else return ()
 778
 779        dumpIfSet_dyn dflags Opt_D_dump_tc
 780                      "Typechecked" (ppr (tc_binds results))
 781
 782
 783 printIfaceDump dflags Nothing = return ()
 784 printIfaceDump dflags (Just (_, details))
 785   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
 786                      "Interface" (pprModDetails details)
 787
 788 dump_tc_iface dflags results
 789   = vcat [pprModDetails (ModDetails {md_types = tc_env results,
 790                                      md_insts = tc_insts results,
 791                                      md_rules = [], md_binds = []}) ,
 792           ppr_rules (tc_rules results),
 793
 794           if dopt Opt_Generics dflags then
 795                 ppr_gen_tycons (typeEnvTyCons (tc_env results))
 796           else
 797                 empty
 798     ]
 799
 800 ppr_rules [] = empty
 801 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
 802                       nest 4 (vcat (map ppr rs)),
 803                       ptext SLIT("#-}")]
 804
 805 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 806                            vcat (map ppr_gen_tycon tcs),
 807                            ptext SLIT("#-}")
 808                      ]
 809
 810 -- x&y are now Id's, not CoreExpr's
 811 ppr_gen_tycon tycon
 812   | Just ep <- tyConGenInfo tycon
 813   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 814
 815   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 816
 817 ppr_ep (EP from to)
 818   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
 819            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 820            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 821     ]
 822   where
 823     (_,from_tau) = tcSplitForAllTys (idType from)
 824 \end{code}