ghc/compiler/typecheck/TcModule.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcModule (
  10         typecheckModule,
  11         SYN_IE(TcResults),
  12         SYN_IE(TcSpecialiseRequests),
  13         SYN_IE(TcDDumpDeriv)
  14     ) where
  15
  16 IMP_Ubiq(){-uitous-}
  17
  18 import HsSyn            ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..),
  19                           TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
  20                           SpecInstSig, DefaultDecl, Sig, Fake, InPat,
  21                           SYN_IE(RecFlag), nonRecursive,  GRHSsAndBinds, Match,
  22                           FixityDecl, IE, ImportDecl
  23                         )
  24 import RnHsSyn          ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
  25 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
  26                           SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds),
  27                           SYN_IE(TypecheckedMonoBinds),
  28                           zonkTopBinds )
  29
  30 import TcMonad
  31 import Inst             ( Inst, emptyLIE, plusLIE )
  32 import TcBinds          ( tcBindsAndThen )
  33 import TcClassDcl       ( tcClassDecls2 )
  34 import TcDefaults       ( tcDefaults )
  35 import TcEnv            ( tcExtendGlobalValEnv, getEnv_LocalIds,
  36                           getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
  37                           tcLookupLocalValueByKey, tcLookupTyCon,
  38                           tcLookupGlobalValueByKeyMaybe )
  39 import SpecEnv          ( SpecEnv )
  40 import TcExpr           ( tcId )
  41 import TcIfaceSig       ( tcInterfaceSigs )
  42 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  43 import TcInstUtil       ( buildInstanceEnvs, InstInfo )
  44 import TcSimplify       ( tcSimplifyTop )
  45 import TcTyClsDecls     ( tcTyAndClassDecls1 )
  46 import TcTyDecls        ( mkDataBinds )
  47 import TcType           ( TcIdOcc(..), SYN_IE(TcType), tcInstType )
  48 import TcKind           ( TcKind )
  49
  50 import RnMonad          ( RnNameSupply(..) )
  51 import Bag              ( listToBag )
  52 import ErrUtils         ( SYN_IE(Warning), SYN_IE(Error) )
  53 import Id               ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
  54 import Maybes           ( catMaybes, MaybeErr )
  55 import Name             ( Name, isLocallyDefined, pprModule )
  56 import Pretty
  57 import TyCon            ( TyCon, isSynTyCon )
  58 import Class            ( GenClass, SYN_IE(Class), classSelIds )
  59 import Type             ( applyTyCon, mkSynTy, SYN_IE(Type) )
  60 import PprType          ( GenType, GenTyVar )
  61 import TysWiredIn       ( unitTy )
  62 import PrelMods         ( gHC_MAIN, mAIN )
  63 import PrelInfo         ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
  64 import TyVar            ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
  65 import Unify            ( unifyTauTy )
  66 import UniqFM           ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
  67                           filterUFM, eltsUFM )
  68 import Unique           ( Unique  )
  69 import UniqSupply       ( UniqSupply )
  70 import Util
  71 import Bag              ( Bag, isEmptyBag )
  72
  73 import FiniteMap        ( emptyFM, FiniteMap )
  74
  75 import Outputable       ( Outputable(..), PprStyle )
  76
  77 tycon_specs = emptyFM
  78 \end{code}
  79
  80 Outside-world interface:
  81 \begin{code}
  82 --ToDo: put this in HsVersions
  83 #if __GLASGOW_HASKELL__ >= 200
  84 # define REAL_WORLD RealWorld
  85 #else
  86 # define REAL_WORLD _RealWorld
  87 #endif
  88
  89
  90 -- Convenient type synonyms first:
  91 type TcResults
  92   = (TypecheckedMonoBinds,
  93      [TyCon], [Class],
  94      Bag InstInfo,              -- Instance declaration information
  95      TcSpecialiseRequests,
  96      TcDDumpDeriv)
  97
  98 type TcSpecialiseRequests
  99   = FiniteMap TyCon [(Bool, [Maybe Type])]
 100     -- source tycon specialisation requests
 101
 102 type TcDDumpDeriv
 103   = PprStyle -> Doc
 104
 105 ---------------
 106 typecheckModule
 107         :: UniqSupply
 108         -> RnNameSupply
 109         -> RenamedHsModule
 110         -> MaybeErr
 111             (TcResults,                 -- if all goes well...
 112              Bag Warning)               -- (we can still get warnings)
 113             (Bag Error,                 -- if we had errors...
 114              Bag Warning)
 115
 116 typecheckModule us rn_name_supply mod
 117   = initTc us (tcModule rn_name_supply mod)
 118 \end{code}
 119
 120 The internal monster:
 121 \begin{code}
 122 tcModule :: RnNameSupply        -- for renaming derivings
 123          -> RenamedHsModule     -- input
 124          -> TcM s TcResults     -- output
 125
 126 tcModule rn_name_supply
 127         (HsModule mod_name verion exports imports fixities decls src_loc)
 128   = tcAddSrcLoc src_loc $       -- record where we're starting
 129
 130     fixTc (\ ~(unf_env ,_) ->
 131         -- unf_env is used for type-checking interface pragmas
 132         -- which is done lazily [ie failure just drops the pragma
 133         -- without having any global-failure effect].
 134         --
 135         -- unf_env is also used to get the pragam info for dfuns.
 136
 137             -- The knot for instance information.  This isn't used at all
 138             -- till we type-check value declarations
 139         fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
 140
 141                  -- Type-check the type and class decls
 142                 -- trace "tcTyAndClassDecls:"   $
 143                 tcTyAndClassDecls1 unf_env rec_inst_mapper decls        `thenTc` \ env ->
 144
 145                 -- trace "tc3" $
 146                     -- Typecheck the instance decls, includes deriving
 147                 tcSetEnv env (
 148                 -- trace "tcInstDecls:" $
 149                 tcInstDecls1 unf_env decls mod_name rn_name_supply
 150                 )                                       `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 151
 152                 -- trace "tc4" $
 153                 buildInstanceEnvs inst_info     `thenTc` \ inst_mapper ->
 154
 155                 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
 156
 157         -- End of inner fix loop
 158         ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
 159
 160         -- trace "tc5" $
 161         tcSetEnv env $
 162
 163             -- Default declarations
 164         tcDefaults decls                `thenTc` \ defaulting_tys ->
 165         tcSetDefaultTys defaulting_tys  $
 166
 167         -- Create any necessary record selector Ids and their bindings
 168         -- "Necessary" includes data and newtype declarations
 169         let
 170             tycons   = getEnv_TyCons env
 171             classes  = getEnv_Classes env
 172         in
 173         mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
 174
 175         -- Extend the global value environment with
 176         --      (a) constructors
 177         --      (b) record selectors
 178         --      (c) class op selectors
 179         --      (d) default-method ids
 180         tcExtendGlobalValEnv data_ids                           $
 181         tcExtendGlobalValEnv (concat (map classSelIds classes)) $
 182
 183
 184             -- Interface type signatures
 185             -- We tie a knot so that the Ids read out of interfaces are in scope
 186             --   when we read their pragmas.
 187             -- What we rely on is that pragmas are typechecked lazily; if
 188             --   any type errors are found (ie there's an inconsistency)
 189             --   we silently discard the pragma
 190         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
 191         tcExtendGlobalValEnv sig_ids            $
 192
 193
 194         -- Value declarations next.
 195         -- We also typecheck any extra binds that came out of the "deriving" process
 196         -- trace "tcBinds:"                     $
 197         tcBindsAndThen
 198             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
 199             (get_val_decls decls `ThenBinds` deriv_binds)
 200             (   tcGetEnv                `thenNF_Tc` \ env ->
 201                 returnTc ((EmptyMonoBinds, env), emptyLIE)
 202             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
 203         tcSetEnv final_env $
 204
 205
 206                 -- Second pass over class and instance declarations,
 207                 -- to compile the bindings themselves.
 208         -- trace "tc8" $
 209         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 210         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
 211
 212
 213
 214         -- Check that "main" has the right signature
 215         tcCheckMainSig mod_name         `thenTc_`
 216
 217              -- Deal with constant or ambiguous InstIds.  How could
 218              -- there be ambiguous ones?  They can only arise if a
 219              -- top-level decl falls under the monomorphism
 220              -- restriction, and no subsequent decl instantiates its
 221              -- type.  (Usually, ambiguous type variables are resolved
 222              -- during the generalisation step.)
 223         -- trace "tc9" $
 224         let
 225             lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls
 226         in
 227         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
 228
 229
 230             -- Backsubstitution.    This must be done last.
 231             -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
 232         let
 233             all_binds = data_binds              `AndMonoBinds`
 234                         val_binds               `AndMonoBinds`
 235                         inst_binds              `AndMonoBinds`
 236                         cls_binds               `AndMonoBinds`
 237                         const_inst_binds
 238         in
 239         zonkTopBinds all_binds  `thenNF_Tc` \ (all_binds', really_final_env)  ->
 240
 241         returnTc (really_final_env, (all_binds', inst_info, ddump_deriv))
 242
 243     -- End of outer fix loop
 244     ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) ->
 245
 246
 247     let
 248         tycons   = getEnv_TyCons   final_env
 249         classes  = getEnv_Classes  final_env
 250
 251         local_tycons  = filter isLocallyDefined tycons
 252         local_classes = filter isLocallyDefined classes
 253     in
 254         -- FINISHED AT LAST
 255     returnTc (
 256         all_binds',
 257
 258         local_tycons, local_classes, inst_info, tycon_specs,
 259
 260         ddump_deriv
 261     )
 262
 263 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 264 \end{code}
 265
 266
 267 \begin{code}
 268 tcCheckMainSig mod_name
 269   | not is_main && not is_ghc_main
 270   = returnTc ()         -- A non-main module
 271
 272   | otherwise
 273   =     -- Check that main is defined
 274     tcLookupTyCon tycon_name                    `thenTc` \ (_,_,tycon) ->
 275     tcLookupLocalValue main_name                `thenNF_Tc` \ maybe_main_id ->
 276     case maybe_main_id of {
 277         Nothing  -> failTc (noMainErr mod_name main_name);
 278         Just main_id   ->
 279
 280         -- Check that it has the right type (or a more general one)
 281     let
 282         expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
 283                     | otherwise        = applyTyCon tycon [unitTy]
 284                 -- This is bizarre.  There ought to be a suitable function in Type.lhs!
 285     in
 286     tcInstType [] expected_ty                   `thenNF_Tc` \ expected_tau ->
 287     tcId main_name                              `thenNF_Tc` \ (_, lie, main_tau) ->
 288     tcSetErrCtxt (mainTyCheckCtxt main_name) $
 289     unifyTauTy expected_tau
 290                main_tau                         `thenTc_`
 291     checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
 292     }
 293   where
 294     is_main     = mod_name == mAIN
 295     is_ghc_main = mod_name == gHC_MAIN
 296
 297     main_name | is_main   = main_NAME
 298               | otherwise = mainPrimIO_NAME
 299
 300     tycon_name | is_main   = ioTyCon_NAME
 301                | otherwise = primIoTyCon_NAME
 302
 303 mainTyCheckCtxt main_name sty
 304   = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
 305
 306 noMainErr mod_name main_name sty
 307   = hsep [ptext SLIT("Module"), pprModule sty mod_name,
 308            ptext SLIT("must include a definition for"), ppr sty main_name]
 309
 310 mainTyMisMatch :: Name -> Type -> TcType s -> Error
 311 mainTyMisMatch main_name expected actual sty
 312   = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
 313          4 (vcat [
 314                         hsep [ptext SLIT("Expected:"), ppr sty expected],
 315                         hsep [ptext SLIT("Inferred:"), ppr sty actual]
 316                      ])
 317 \end{code}