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