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