\section[TcModule]{Typechecking a whole module}
\begin{code}
-#include "HsVersions.h"
-
module TcModule (
typecheckModule,
- SYN_IE(TcResults),
- SYN_IE(TcSpecialiseRequests),
- SYN_IE(TcDDumpDeriv)
+ TcResults,
+ TcDDumpDeriv
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv )
-import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..),
- TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
- SpecInstSig, DefaultDecl, Sig, Fake, InPat,
- SYN_IE(RecFlag), nonRecursive, GRHSsAndBinds, Match,
- FixityDecl, IE, ImportDecl, OutPat
- )
-import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
-import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
- SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds),
- SYN_IE(TypecheckedMonoBinds),
+import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
+import RnHsSyn ( RenamedHsModule, RenamedFixityDecl(..) )
+import TcHsSyn ( TypecheckedHsBinds, TypecheckedHsExpr,
+ TypecheckedDictBinds, TcMonoBinds,
+ TypecheckedMonoBinds,
zonkTopBinds )
import TcMonad
import Inst ( Inst, emptyLIE, plusLIE )
-import TcBinds ( tcBindsAndThen )
+import TcBinds ( tcTopBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
+import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv, getEnv_LocalIds,
getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
tcLookupLocalValueByKey, tcLookupTyCon,
tcLookupGlobalValueByKeyMaybe )
-import SpecEnv ( SpecEnv )
import TcExpr ( tcId )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcInstUtil ( buildInstanceEnvs, InstInfo )
+import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls1 )
import TcTyDecls ( mkDataBinds )
-import TcType ( TcIdOcc(..), SYN_IE(TcType), tcInstType )
-import TcKind ( TcKind )
+import TcType ( TcType, tcInstType )
+import TcKind ( TcKind, kindToTcKind )
import RnMonad ( RnNameSupply(..) )
-import Bag ( listToBag )
-import ErrUtils ( SYN_IE(Warning), SYN_IE(Error),
+import Bag ( isEmptyBag )
+import ErrUtils ( WarnMsg, ErrMsg,
pprBagOfErrors, dumpIfSet, ghcExit
)
-import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
+import Id ( idType, GenId, IdEnv, nullIdEnv )
import Maybes ( catMaybes, MaybeErr(..) )
-import Name ( Name, isLocallyDefined, pprModule )
-import Pretty
-import TyCon ( TyCon, isSynTyCon )
-import Class ( GenClass, SYN_IE(Class), classSelIds )
-import Type ( applyTyCon, mkSynTy, SYN_IE(Type) )
-import PprType ( GenType, GenTyVar )
+import Name ( Name, isLocallyDefined, pprModule, NamedThing(..) )
+import TyCon ( TyCon, isSynTyCon, tyConKind )
+import Class ( Class, classSelIds, classTyCon )
+import Type ( mkTyConApp, mkSynTy, Type )
+import TyVar ( emptyTyVarEnv )
import TysWiredIn ( unitTy )
import PrelMods ( gHC_MAIN, mAIN )
import PrelInfo ( main_NAME, ioTyCon_NAME )
-import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
import UniqSupply ( UniqSupply )
import Util
import Bag ( Bag, isEmptyBag )
-
import FiniteMap ( emptyFM, FiniteMap )
-
-import Outputable ( Outputable(..), PprStyle, printErrs, pprDumpStyle, pprErrorsStyle )
-
-tycon_specs = emptyFM
+import Outputable
\end{code}
Outside-world interface:
\begin{code}
---ToDo: put this in HsVersions
-#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD RealWorld
-#else
-# define REAL_WORLD _RealWorld
-#endif
-
-- Convenient type synonyms first:
type TcResults
= (TypecheckedMonoBinds,
[TyCon], [Class],
Bag InstInfo, -- Instance declaration information
- TcSpecialiseRequests,
TcDDumpDeriv)
-type TcSpecialiseRequests
- = FiniteMap TyCon [(Bool, [Maybe Type])]
- -- source tycon specialisation requests
-
-type TcDDumpDeriv
- = PprStyle -> Doc
+type TcDDumpDeriv = SDoc
---------------
typecheckModule
-> IO (Maybe TcResults)
typecheckModule us rn_name_supply mod
- = case initTc us (tcModule rn_name_supply mod) of
- Failed (errs, warns) ->
- print_errs warns >>
- print_errs errs >>
- return Nothing
-
- Succeeded (results@(binds, _, _, _, _, dump_deriv), warns) ->
- print_errs warns >>
+ = let
+ (maybe_result, warns, errs) = initTc us (tcModule rn_name_supply mod)
+ in
+ print_errs warns >>
+ print_errs errs >>
- dumpIfSet opt_D_dump_tc "Typechecked"
- (ppr pprDumpStyle binds) >>
+ dumpIfSet opt_D_dump_tc "Typechecked"
+ (case maybe_result of
+ Just (binds, _, _, _, _) -> ppr binds
+ Nothing -> text "Typecheck failed") >>
- dumpIfSet opt_D_dump_deriv "Derived instances"
- (dump_deriv pprDumpStyle) >>
+ dumpIfSet opt_D_dump_deriv "Derived instances"
+ (case maybe_result of
+ Just (_, _, _, _, dump_deriv) -> dump_deriv
+ Nothing -> empty) >>
- return (Just results)
+ return (if isEmptyBag errs then
+ maybe_result
+ else
+ Nothing)
print_errs errs
| isEmptyBag errs = return ()
- | otherwise = printErrs (pprBagOfErrors pprErrorsStyle errs)
+ | otherwise = printErrs (pprBagOfErrors errs)
\end{code}
The internal monster:
tcSetEnv env (
-- trace "tcInstDecls:" $
tcInstDecls1 unf_env decls mod_name rn_name_supply
- ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+ ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
-- trace "tc4" $
- buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
+ buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper ->
returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
-- Create any necessary record selector Ids and their bindings
-- "Necessary" includes data and newtype declarations
let
- tycons = getEnv_TyCons env
- classes = getEnv_Classes env
+ tycons = getEnv_TyCons env
+ classes = getEnv_Classes env
+ local_tycons = filter isLocallyDefined tycons
+ local_classes = filter isLocallyDefined classes
in
mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
tcExtendGlobalValEnv data_ids $
tcExtendGlobalValEnv (concat (map classSelIds classes)) $
+ -- Extend the TyCon envt with the tycons corresponding to
+ -- the classes, and the global value environment with the
+ -- corresponding data cons.
+ -- They are mentioned in types in interface files.
+ tcExtendGlobalValEnv (map classDataCon classes) $
+ tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon))
+ | clas <- classes,
+ let tycon = classTyCon clas
+ ] $
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
-- trace "tcBinds:" $
- tcBindsAndThen
+ tcTopBindsAndThen
(\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
(get_val_decls decls `ThenBinds` deriv_binds)
( tcGetEnv `thenNF_Tc` \ env ->
in
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
- returnTc (really_final_env, (all_binds', inst_info, ddump_deriv))
+ returnTc (really_final_env,
+ (all_binds', local_tycons, local_classes, inst_info, ddump_deriv))
-- End of outer fix loop
- ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) ->
-
-
- let
- tycons = getEnv_TyCons final_env
- classes = getEnv_Classes final_env
-
- local_tycons = filter isLocallyDefined tycons
- local_classes = filter isLocallyDefined classes
- in
- -- FINISHED AT LAST
- returnTc (
- all_binds',
-
- local_tycons, local_classes, inst_info, tycon_specs,
-
- ddump_deriv
- )
+ ) `thenTc` \ (final_env, stuff) ->
+ returnTc stuff
get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id ->
case maybe_main_id of {
- Nothing -> failTc noMainErr;
+ Nothing -> failWithTc noMainErr ;
Just main_id ->
-- Check that it has the right type (or a more general one)
- let expected_ty = applyTyCon ioTyCon [unitTy] in
- tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
- tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
+ let
+ expected_ty = mkTyConApp ioTyCon [unitTy]
+ in
+ tcInstType emptyTyVarEnv expected_ty `thenNF_Tc` \ expected_tau ->
+ tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
tcSetErrCtxt mainTyCheckCtxt $
unifyTauTy expected_tau
main_tau `thenTc_`
checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id))
}
-mainTyCheckCtxt sty
- = hsep [ptext SLIT("When checking that"), ppr sty main_NAME,
- ptext SLIT("has the required type")]
-noMainErr sty
- = hsep [ptext SLIT("Module"), pprModule sty mAIN,
- ptext SLIT("must include a definition for"), ppr sty main_NAME]
+mainTyCheckCtxt
+ = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
+
+noMainErr
+ = hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
+ ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
-mainTyMisMatch :: Type -> TcType s -> Error
-mainTyMisMatch expected actual sty
- = hang (hsep [ppr sty main_NAME, ptext SLIT("has the wrong type")])
+mainTyMisMatch :: Type -> TcType s -> ErrMsg
+mainTyMisMatch expected actual
+ = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")])
4 (vcat [
- hsep [ptext SLIT("Expected:"), ppr sty expected],
- hsep [ptext SLIT("Inferred:"), ppr sty actual]
+ hsep [ptext SLIT("Expected:"), ppr expected],
+ hsep [ptext SLIT("Inferred:"), ppr actual]
])
\end{code}
projects / ghc-hetmet.git / blobdiff