projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Major bugfixing pass through the type checker
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcSMonad.lhs
diff --git
a/compiler/typecheck/TcSMonad.lhs
b/compiler/typecheck/TcSMonad.lhs
index
4965a93
..
f8b357a
100644
(file)
--- a/
compiler/typecheck/TcSMonad.lhs
+++ b/
compiler/typecheck/TcSMonad.lhs
@@
-31,11
+31,12
@@
module TcSMonad (
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
- getTcEvBindsBag, getTcSContext, getTcSTyBinds,
+ getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsBag,
newFlattenSkolemTy, -- Flatten skolems
newFlattenSkolemTy, -- Flatten skolems
+
instDFunTypes, -- Instantiation
instDFunConstraints,
instDFunTypes, -- Instantiation
instDFunConstraints,
@@
-63,7
+64,6
@@
module TcSMonad (
import HscTypes
import BasicTypes
import HscTypes
import BasicTypes
-import Type
import Inst
import InstEnv
import Inst
import InstEnv
@@
-83,6
+83,8
@@
import DynFlags
import Coercion
import Class
import TyCon
import Coercion
import Class
import TyCon
+import TypeRep
+
import Name
import Var
import Outputable
import Name
import Var
import Outputable
@@
-431,6
+433,7
@@
runTcS context untouch tcs
; return (res, evBindMapBinds ev_binds) }
where
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
; return (res, evBindMapBinds ev_binds) }
where
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
+
nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
nestImplicTcS ref untouch tcs
nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
nestImplicTcS ref untouch tcs
@@
-472,6
+475,10
@@
getTcEvBinds = TcS (return . tcs_ev_binds)
getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
+getTcSTyBindsBag :: TcS (Bag (TcTyVar, TcType))
+getTcSTyBindsBag = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
+
+
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
@@
-570,7
+577,8
@@
newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
newFlattenSkolemTyVar ty
= wrapTcS $ do { uniq <- TcM.newUnique
; let name = mkSysTvName uniq (fsLit "f")
newFlattenSkolemTyVar ty
= wrapTcS $ do { uniq <- TcM.newUnique
; let name = mkSysTvName uniq (fsLit "f")
- ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
+ ; return $
+ mkTcTyVar name (typeKind ty) (FlatSkol ty)
}
-- Instantiations
}
-- Instantiations