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