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