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