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