projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 1997-05-18 22:25:51 by sof]
[ghc-hetmet.git]
/
ghc
/
compiler
/
typecheck
/
TcModule.lhs
diff --git
a/ghc/compiler/typecheck/TcModule.lhs
b/ghc/compiler/typecheck/TcModule.lhs
index
a5c3197
..
33dd1c8
100644
(file)
--- a/
ghc/compiler/typecheck/TcModule.lhs
+++ b/
ghc/compiler/typecheck/TcModule.lhs
@@
-16,14
+16,16
@@
module TcModule (
IMP_Ubiq(){-uitous-}
IMP_Ubiq(){-uitous-}
-import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), Bind, HsExpr,
+import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds,
TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
+ SYN_IE(RecFlag), nonRecursive,
FixityDecl, IE, ImportDecl
)
import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
FixityDecl, IE, ImportDecl
)
import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
- TcIdOcc(..), zonkBinds, zonkDictBinds )
+ SYN_IE(TypecheckedDictBinds),
+ TcIdOcc(..), zonkBinds )
import TcMonad
import Inst ( Inst, plusLIE )
import TcMonad
import Inst ( Inst, plusLIE )
@@
-47,15
+49,16
@@
import TcKind ( TcKind )
import RnMonad ( RnNameSupply(..) )
import Bag ( listToBag )
import RnMonad ( RnNameSupply(..) )
import Bag ( listToBag )
-import Class ( GenClass, classSelIds )
import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
-import Maybes ( catMaybes )
+import Maybes ( catMaybes, MaybeErr )
import Name ( Name, isLocallyDefined, pprModule )
import Pretty
import TyCon ( TyCon, isSynTyCon )
import Name ( Name, isLocallyDefined, pprModule )
import Pretty
import TyCon ( TyCon, isSynTyCon )
-import Type ( applyTyCon, mkSynTy )
+import Class ( GenClass, SYN_IE(Class), classGlobalIds )
+import Type ( applyTyCon, mkSynTy, SYN_IE(Type) )
import PprType ( GenType, GenTyVar )
import PprType ( GenType, GenTyVar )
+import PprStyle ( PprStyle )
import TysWiredIn ( unitTy )
import PrelMods ( gHC_MAIN, mAIN )
import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
import TysWiredIn ( unitTy )
import PrelMods ( gHC_MAIN, mAIN )
import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
@@
-64,10
+67,16
@@
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
import Unique ( Unique )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
import Unique ( Unique )
+import UniqSupply ( UniqSupply )
import Util
import Bag ( Bag, isEmptyBag )
import FiniteMap ( emptyFM, FiniteMap )
import Util
import Bag ( Bag, isEmptyBag )
import FiniteMap ( emptyFM, FiniteMap )
+
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
+
tycon_specs = emptyFM
\end{code}
tycon_specs = emptyFM
\end{code}
@@
-76,7
+85,7
@@
Outside-world interface:
-- Convenient type synonyms first:
type TcResults
= (TcResultBinds,
-- Convenient type synonyms first:
type TcResults
= (TcResultBinds,
- [TyCon],
+ [TyCon], [Class],
Bag InstInfo, -- Instance declaration information
TcSpecialiseRequests,
TcDDumpDeriv)
Bag InstInfo, -- Instance declaration information
TcSpecialiseRequests,
TcDDumpDeriv)
@@
-89,14
+98,14
@@
type TcResultBinds
-- class default-methods binds
TypecheckedHsBinds, -- binds from value decls
-- class default-methods binds
TypecheckedHsBinds, -- binds from value decls
- [(Id, TypecheckedHsExpr)]) -- constant instance binds
+ TypecheckedHsBinds) -- constant instance binds
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
type TcDDumpDeriv
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
type TcDDumpDeriv
- = PprStyle -> Pretty
+ = PprStyle -> Doc
---------------
typecheckModule
---------------
typecheckModule
@@
-176,8
+185,9
@@
tcModule rn_name_supply
-- a) constructors
-- b) record selectors
-- c) class op selectors
-- a) constructors
-- b) record selectors
-- c) class op selectors
+ -- d) default-method ids
tcExtendGlobalValEnv data_ids $
tcExtendGlobalValEnv data_ids $
- tcExtendGlobalValEnv (concat (map classSelIds classes)) $
+ tcExtendGlobalValEnv (concat (map classGlobalIds classes)) $
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
@@
-211,10
+221,11
@@
tcModule rn_name_supply
tcCheckMainSig mod_name `thenTc_`
tcGetEnv `thenNF_Tc` \ env ->
returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
tcCheckMainSig mod_name `thenTc_`
tcGetEnv `thenNF_Tc` \ env ->
returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
- lie_instdecls `plusLIE` lie_clasdecls,
- () ))
+ lie_instdecls `plusLIE` lie_clasdecls
+ )
+ )
- `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
+ `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
@@
-238,7
+249,8
@@
tcModule rn_name_supply
-- These bindings ought really to be bundled together in a huge
-- recursive group, but HsSyn doesn't have recursion among Binds, only
-- among MonoBinds. Sigh again.
-- These bindings ought really to be bundled together in a huge
-- recursive group, but HsSyn doesn't have recursion among Binds, only
-- among MonoBinds. Sigh again.
- zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) ->
+ zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
+ `thenNF_Tc` \ (const_insts', ve1) ->
zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
@@
-257,7
+269,7
@@
tcModule rn_name_supply
returnTc (
(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
returnTc (
(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
- local_tycons, inst_info, tycon_specs,
+ local_tycons, local_classes, inst_info, tycon_specs,
ddump_deriv
)))
ddump_deriv
)))
@@
-303,17
+315,17
@@
tcCheckMainSig mod_name
| otherwise = primIoTyCon_NAME
mainTyCheckCtxt main_name sty
| otherwise = primIoTyCon_NAME
mainTyCheckCtxt main_name sty
- = ppCat [ppStr "When checking that", ppr sty main_name, ppStr "has the required type"]
+ = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
noMainErr mod_name main_name sty
noMainErr mod_name main_name sty
- = ppCat [ppStr "Module", pprModule sty mod_name,
- ppStr "must include a definition for", ppr sty main_name]
+ = hsep [ptext SLIT("Module"), pprModule sty mod_name,
+ ptext SLIT("must include a definition for"), ppr sty main_name]
mainTyMisMatch :: Name -> Type -> TcType s -> Error
mainTyMisMatch main_name expected actual sty
mainTyMisMatch :: Name -> Type -> TcType s -> Error
mainTyMisMatch main_name expected actual sty
- = ppHang (ppCat [ppr sty main_name, ppStr "has the wrong type"])
- 4 (ppAboves [
- ppCat [ppStr "Expected:", ppr sty expected],
- ppCat [ppStr "Inferred:", ppr sty actual]
+ = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
+ 4 (vcat [
+ hsep [ptext SLIT("Expected:"), ppr sty expected],
+ hsep [ptext SLIT("Inferred:"), ppr sty actual]
])
\end{code}
])
\end{code}