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 HsTypes          ( toHsType )
  17 import RnHsSyn          ( RenamedHsModule )
  18 import TcHsSyn          ( TypecheckedMonoBinds,
  19                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  20                           zonkTopBinds, zonkForeignExports, zonkRules
  21                         )
  22
  23 import TcMonad
  24 import Inst             ( emptyLIE, plusLIE )
  25 import TcBinds          ( tcTopBindsAndThen )
  26 import TcClassDcl       ( tcClassDecls2, mkImplicitClassBinds )
  27 import TcDefaults       ( tcDefaults )
  28 import TcEnv            ( tcExtendGlobalValEnv,
  29                           getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
  30                           tcSetValueEnv, tcSetInstEnv, initEnv,
  31                           ValueEnv,
  32                         )
  33 import TcRules          ( tcRules )
  34 import TcForeign        ( tcForeignImports, tcForeignExports )
  35 import TcIfaceSig       ( tcInterfaceSigs )
  36 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  37 import TcInstUtil       ( buildInstanceEnv, InstInfo )
  38 import TcSimplify       ( tcSimplifyTop )
  39 import TcTyClsDecls     ( tcTyAndClassDecls )
  40 import TcTyDecls        ( mkImplicitDataBinds )
  41
  42 import RnMonad          ( RnNameSupply, FixityEnv )
  43 import Bag              ( isEmptyBag )
  44 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet )
  45 import Id               ( idType, idName )
  46 import Module           ( pprModuleName, mkThisModule )
  47 import Name             ( nameOccName, isLocallyDefined, isGlobalName,
  48                           toRdrName, nameEnvElts,
  49                         )
  50 import OccName          ( isSysOcc )
  51 import TyCon            ( TyCon, tyConClass_maybe )
  52 import Class            ( Class )
  53 import PrelInfo         ( mAIN_Name )
  54 import Unique           ( mainKey )
  55 import UniqSupply       ( UniqSupply )
  56 import Maybes           ( maybeToBool )
  57 import Util
  58 import Bag              ( Bag, isEmptyBag )
  59 import Outputable
  60 \end{code}
  61
  62 Outside-world interface:
  63 \begin{code}
  64
  65 -- Convenient type synonyms first:
  66 data TcResults
  67   = TcResults {
  68         tc_binds   :: TypecheckedMonoBinds,
  69         tc_tycons  :: [TyCon],
  70         tc_classes :: [Class],
  71         tc_insts   :: Bag InstInfo,             -- Instance declaration information
  72         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
  73         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
  74         tc_env     :: ValueEnv
  75     }
  76
  77 ---------------
  78 typecheckModule
  79         :: UniqSupply
  80         -> RnNameSupply
  81         -> FixityEnv
  82         -> RenamedHsModule
  83         -> IO (Maybe TcResults)
  84
  85 typecheckModule us rn_name_supply fixity_env mod
  86   = initTc us initEnv (tcModule rn_name_supply fixity_env mod)  >>= \ (maybe_result, warns, errs) ->
  87
  88     printErrorsAndWarnings errs warns           >>
  89
  90     (case maybe_result of
  91         Nothing -> return ()
  92         Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >>
  93                         dumpIfSet opt_D_dump_tc    "Typechecked"     (dump_tc   results)
  94     )                                           >>
  95
  96     return (if isEmptyBag errs then
  97                 maybe_result
  98             else
  99                 Nothing)
 100
 101 dump_tc results
 102   = ppr (tc_binds results) $$ pp_rules (tc_rules results)
 103
 104 dump_sigs results       -- Print type signatures
 105   =     -- Convert to HsType so that we get source-language style printing
 106         -- And sort by RdrName
 107     vcat $ map ppr_sig $ sortLt lt_sig $
 108     [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
 109                                             want_sig id
 110     ]
 111   where
 112     lt_sig (n1,_) (n2,_) = n1 < n2
 113     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 114
 115     want_sig id | opt_PprStyle_Debug = True
 116                 | otherwise          = isLocallyDefined n &&
 117                                        isGlobalName n &&
 118                                        not (isSysOcc (nameOccName n))
 119                                      where
 120                                        n = idName id
 121
 122 pp_rules [] = empty
 123 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 124                     nest 4 (vcat (map ppr rs)),
 125                     ptext SLIT("#-}")]
 126 \end{code}
 127
 128 The internal monster:
 129 \begin{code}
 130 tcModule :: RnNameSupply        -- for renaming derivings
 131          -> FixityEnv           -- needed for Show/Read derivings.
 132          -> RenamedHsModule     -- input
 133          -> TcM s TcResults     -- output
 134
 135 tcModule rn_name_supply fixities
 136         (HsModule mod_name _ _ _ decls _ src_loc)
 137   = tcAddSrcLoc src_loc $       -- record where we're starting
 138
 139     fixTc (\ ~(unf_env ,_) ->
 140         -- unf_env is used for type-checking interface pragmas
 141         -- which is done lazily [ie failure just drops the pragma
 142         -- without having any global-failure effect].
 143         --
 144         -- unf_env is also used to get the pragam info
 145         -- for imported dfuns and default methods
 146
 147                  -- Type-check the type and class decls
 148         tcTyAndClassDecls unf_env decls `thenTc` \ env ->
 149
 150                  -- Typecheck the instance decls, includes deriving
 151         tcSetEnv env $
 152
 153         tcInstDecls1 unf_env decls
 154                      (mkThisModule mod_name)
 155                      fixities rn_name_supply    `thenTc` \ (inst_info, deriv_binds) ->
 156
 157         buildInstanceEnv inst_info      `thenNF_Tc` \ inst_env ->
 158
 159         tcSetInstEnv inst_env $
 160         let
 161             classes      = getEnvClasses env
 162             tycons       = getEnvTyCons env     -- INCLUDES tycons derived from classes
 163             local_classes = filter isLocallyDefined classes
 164             local_tycons  = [ tc | tc <- tycons,
 165                                    isLocallyDefined tc,
 166                                    Nothing <- [tyConClass_maybe tc]
 167                             ]
 168                                 -- For local_tycons, filter out the ones derived from classes
 169                                 -- Otherwise the latter show up in interface files
 170         in
 171
 172             -- Default declarations
 173         tcDefaults decls                `thenTc` \ defaulting_tys ->
 174         tcSetDefaultTys defaulting_tys  $
 175
 176         -- Interface type signatures
 177         -- We tie a knot so that the Ids read out of interfaces are in scope
 178         --   when we read their pragmas.
 179         -- What we rely on is that pragmas are typechecked lazily; if
 180         --   any type errors are found (ie there's an inconsistency)
 181         --   we silently discard the pragma
 182         -- We must do this before mkImplicitDataBinds (which comes next), since
 183         -- the latter looks up unpackCStringId, for example, which is usually
 184         -- imported
 185         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
 186         tcExtendGlobalValEnv sig_ids            $
 187
 188         -- Create any necessary record selector Ids and their bindings
 189         -- "Necessary" includes data and newtype declarations
 190         -- We don't create bindings for dictionary constructors;
 191         -- they are always fully applied, and the bindings are just there
 192         -- to support partial applications
 193         mkImplicitDataBinds tycons              `thenTc`    \ (data_ids, imp_data_binds) ->
 194         mkImplicitClassBinds classes            `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
 195
 196         -- Extend the global value environment with
 197         --      (a) constructors
 198         --      (b) record selectors
 199         --      (c) class op selectors
 200         --      (d) default-method ids... where? I can't see where these are
 201         --          put into the envt, and I'm worried that the zonking phase
 202         --          will find they aren't there and complain.
 203         tcExtendGlobalValEnv data_ids           $
 204         tcExtendGlobalValEnv cls_ids            $
 205
 206             -- foreign import declarations next.
 207         tcForeignImports decls          `thenTc`    \ (fo_ids, foi_decls) ->
 208         tcExtendGlobalValEnv fo_ids             $
 209
 210         -- Value declarations next.
 211         -- We also typecheck any extra binds that came out of the "deriving" process
 212         tcTopBindsAndThen
 213             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
 214             (get_val_decls decls `ThenBinds` deriv_binds)
 215             (   tcGetEnv                                `thenNF_Tc` \ env ->
 216                 tcGetUnique                             `thenNF_Tc` \ uniq ->
 217                 returnTc ((EmptyMonoBinds, env), emptyLIE)
 218             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
 219         tcSetEnv final_env $
 220
 221             -- foreign export declarations next.
 222         tcForeignExports decls          `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 223
 224                 -- Second pass over class and instance declarations,
 225                 -- to compile the bindings themselves.
 226         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 227         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 228         tcRules decls                   `thenNF_Tc` \ (lie_rules,     rules) ->
 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   `plusLIE`
 242                            lie_rules
 243         in
 244         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
 245
 246                 -- Check that Main defines main
 247         (if mod_name == mAIN_Name then
 248                 tcLookupValueByKeyMaybe mainKey         `thenNF_Tc` \ maybe_main ->
 249                 checkTc (maybeToBool maybe_main) noMainErr
 250          else
 251                 returnTc ()
 252         )                                       `thenTc_`
 253
 254             -- Backsubstitution.    This must be done last.
 255             -- Even tcSimplifyTop may do some unification.
 256         let
 257             all_binds = imp_data_binds          `AndMonoBinds`
 258                         imp_cls_binds           `AndMonoBinds`
 259                         val_binds               `AndMonoBinds`
 260                         inst_binds              `AndMonoBinds`
 261                         cls_dm_binds            `AndMonoBinds`
 262                         const_inst_binds        `AndMonoBinds`
 263                         foe_binds
 264         in
 265         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', really_final_env)  ->
 266         tcSetValueEnv really_final_env  $
 267         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 268         zonkRules rules                 `thenNF_Tc` \ rules' ->
 269
 270         returnTc (really_final_env,
 271                   (TcResults {  tc_binds   = all_binds',
 272                                 tc_tycons  = local_tycons,
 273                                 tc_classes = local_classes,
 274                                 tc_insts   = inst_info,
 275                                 tc_fords   = foi_decls ++ foe_decls',
 276                                 tc_rules   = rules',
 277                                 tc_env     = really_final_env
 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 (pprModuleName mAIN_Name),
 291           ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
 292 \end{code}
 293