projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Replace ioToTcRn with liftIO
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcTyFuns.lhs
diff --git
a/compiler/typecheck/TcTyFuns.lhs
b/compiler/typecheck/TcTyFuns.lhs
index
d7da2f7
..
82e397f
100644
(file)
--- a/
compiler/typecheck/TcTyFuns.lhs
+++ b/
compiler/typecheck/TcTyFuns.lhs
@@
-40,7
+40,7
@@
import Maybes
-- standard
import Data.List
-- standard
import Data.List
-import Control.Monad (liftM)
+import Control.Monad
\end{code}
\end{code}
@@
-233,7
+233,7
@@
tcGenericNormaliseFamInst fun (ForAllTy tyvar ty1)
}
tcGenericNormaliseFamInst fun (NoteTy note ty1)
= do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
}
tcGenericNormaliseFamInst fun (NoteTy note ty1)
= do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
- ; return (mkNoteTyCoI note coi, NoteTy note nty1)
+ ; return (coi, NoteTy note nty1)
}
tcGenericNormaliseFamInst fun ty@(TyVarTy tv)
| isTcTyVar tv
}
tcGenericNormaliseFamInst fun ty@(TyVarTy tv)
| isTcTyVar tv
@@
-388,14
+388,18
@@
normalise_dicts
-- Fals <=> they are given
-> TcM ([Inst],TcDictBinds)
normalise_dicts given_eqs dicts is_wanted
-- Fals <=> they are given
-> TcM ([Inst],TcDictBinds)
normalise_dicts given_eqs dicts is_wanted
- = do { traceTc $ text "normalise???Dicts <-" <+> ppr dicts <+>
+ = do { traceTc $ let name | is_wanted = "normaliseWantedDicts <-"
+ | otherwise = "normaliseGivenDicts <-"
+ in
+ text name <+> ppr dicts <+>
text "with" <+> ppr given_eqs
; (dicts0, binds0) <- normaliseInsts is_wanted dicts
text "with" <+> ppr given_eqs
; (dicts0, binds0) <- normaliseInsts is_wanted dicts
- ; (dicts1, binds1) <- substEqInDictInsts given_eqs dicts0
+ ; (dicts1, binds1) <- substEqInDictInsts is_wanted given_eqs dicts0
; let binds01 = binds0 `unionBags` binds1
; if isEmptyBag binds1
then return (dicts1, binds01)
; let binds01 = binds0 `unionBags` binds1
; if isEmptyBag binds1
then return (dicts1, binds01)
- else do { (dicts2, binds2) <- normaliseGivenDicts given_eqs dicts1
+ else do { (dicts2, binds2) <-
+ normalise_dicts given_eqs dicts1 is_wanted
; return (dicts2, binds01 `unionBags` binds2) } }
\end{code}
; return (dicts2, binds01 `unionBags` binds2) } }
\end{code}
@@
-659,7
+663,7
@@
The following rules exploits the reflexivity of equality:
\begin{code}
trivialRule :: IdemRewriteRule
trivialRule insts
\begin{code}
trivialRule :: IdemRewriteRule
trivialRule insts
- = liftM catMaybes $ mappM trivial insts
+ = liftM catMaybes $ mapM trivial insts
where
trivial inst
| ASSERT( isEqInst inst )
where
trivial inst
| ASSERT( isEqInst inst )
@@
-1080,10
+1084,11
@@
form
where F is a type family.
\begin{code}
where F is a type family.
\begin{code}
-substEqInDictInsts :: [Inst] -- given equalities (used as rewrite rules)
+substEqInDictInsts :: Bool -- whether the *dictionaries* are wanted/given
+ -> [Inst] -- given equalities (used as rewrite rules)
-> [Inst] -- dictinaries to be normalised
-> TcM ([Inst], TcDictBinds)
-> [Inst] -- dictinaries to be normalised
-> TcM ([Inst], TcDictBinds)
-substEqInDictInsts eqInsts dictInsts
+substEqInDictInsts isWanted eqInsts dictInsts
= do { traceTc (text "substEqInDictInst <-" <+> ppr dictInsts)
; dictInsts' <-
foldlM rewriteWithOneEquality (dictInsts, emptyBag) eqInsts
= do { traceTc (text "substEqInDictInst <-" <+> ppr dictInsts)
; dictInsts' <-
foldlM rewriteWithOneEquality (dictInsts, emptyBag) eqInsts
@@
-1097,7
+1102,7
@@
substEqInDictInsts eqInsts dictInsts
tci_right = target})
| isOpenSynTyConApp pattern || isTyVarTy pattern
= do { (dictInsts', moreDictBinds) <-
tci_right = target})
| isOpenSynTyConApp pattern || isTyVarTy pattern
= do { (dictInsts', moreDictBinds) <-
- genericNormaliseInsts True {- wanted -} applyThisEq dictInsts
+ genericNormaliseInsts isWanted applyThisEq dictInsts
; return (dictInsts', dictBinds `unionBags` moreDictBinds)
}
where
; return (dictInsts', dictBinds `unionBags` moreDictBinds)
}
where
@@
-1176,7
+1181,13
@@
genericNormaliseInsts isWanted fun insts
rhs = L (instLocSpan loc) cast_expr
binds = instToDictBind target_dict rhs
-- return the new inst
rhs = L (instLocSpan loc) cast_expr
binds = instToDictBind target_dict rhs
-- return the new inst
- ; traceTc $ text "genericNormaliseInst ->" <+> ppr dict'
+ ; traceTc $ let name | isWanted
+ = "genericNormaliseInst (wanted) ->"
+ | otherwise
+ = "genericNormaliseInst (given) ->"
+ in
+ text name <+> ppr dict' <+>
+ text "with" <+> ppr binds
; return (dict', binds)
}
}
; return (dict', binds)
}
}
@@
-1184,6
+1195,8
@@
genericNormaliseInsts isWanted fun insts
-- TOMDO: What do we have to do about ImplicInst, Method, and LitInst??
normaliseOneInst _isWanted _fun inst
= do { inst' <- zonkInst inst
-- TOMDO: What do we have to do about ImplicInst, Method, and LitInst??
normaliseOneInst _isWanted _fun inst
= do { inst' <- zonkInst inst
+ ; traceTc $ text "*** TcTyFuns.normaliseOneInst: Skipping" <+>
+ ppr inst
; return (inst', emptyBag)
}
\end{code}
; return (inst', emptyBag)
}
\end{code}