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