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