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