X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=3d8163d997dfdd6cdb173a49b85c968bdb4f0946;hb=51367fba96fd863ce7d3e2571bd22366b47b900a;hp=a487fe0e9353c3938a918d064aa51fed7b08a1d9;hpb=162c7e780267c73495fb245a873f7e3b8431471b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index a487fe0..3d8163d 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -4,12 +4,16 @@ module TcSMonad (
 
        -- Canonical constraints
     CanonicalCts, emptyCCan, andCCan, andCCans, 
-    singleCCan, extendCCans, isEmptyCCan, isTyEqCCan, 
+    singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, 
+    isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, 
+
     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
     mkWantedConstraints, deCanonicaliseWanted, 
     makeGivens, makeSolvedByInst,
 
     CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, 
+    isGivenCt, isWantedCt, 
+
     DerivedOrig (..), 
     canRewrite, canSolve,
     combineCtLoc, mkGivenFlavor,
@@ -140,7 +144,7 @@ data CanonicalCt
   | CIPCan {	-- ?x::tau
       -- See note [Canonical implicit parameter constraints].
       cc_id     :: EvVar,
-      cc_flavor :: CtFlavor, 
+      cc_flavor :: CtFlavor,
       cc_ip_nm  :: IPName Name,
       cc_ip_ty  :: TcTauType
     }
@@ -150,10 +154,11 @@ data CanonicalCt
        --   * tv not in tvs(xi)   (occurs check)
        --   * If constraint is given then typeKind xi `compatKind` typeKind tv 
        --                See Note [Spontaneous solving and kind compatibility] 
-       --   * if xi is a flatten skolem then tv must be a flatten skolem
-       --     i.e. equalities prefer flatten skolems in their LHS. 
-       --                See Note [Loopy Spontaneous Solving, Example 4]
-       --                Also related to [Flatten Skolem Equivalence Classes]
+       --   * If 'xi' is a flatten skolem then 'tv' can only be: 
+       --              - a flatten skolem or a unification variable
+       --     i.e. equalities prefer flatten skolems in their LHS 
+       --     See Note [Loopy Spontaneous Solving, Example 4]
+       --     Also related to [Flatten Skolem Equivalence Classes]
       cc_id     :: EvVar, 
       cc_flavor :: CtFlavor, 
       cc_tyvar  :: TcTyVar, 
@@ -278,10 +283,22 @@ emptyCCan = emptyBag
 isEmptyCCan :: CanonicalCts -> Bool
 isEmptyCCan = isEmptyBag
 
-isTyEqCCan :: CanonicalCt -> Bool 
-isTyEqCCan (CTyEqCan {})  = True 
-isTyEqCCan (CFunEqCan {}) = False
-isTyEqCCan _              = False 
+isCTyEqCan :: CanonicalCt -> Bool 
+isCTyEqCan (CTyEqCan {})  = True 
+isCTyEqCan (CFunEqCan {}) = False
+isCTyEqCan _              = False 
+
+isCDictCan_Maybe :: CanonicalCt -> Maybe Class
+isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
+isCDictCan_Maybe _              = Nothing
+
+isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name)
+isCIPCan_Maybe  (CIPCan {cc_ip_nm = nm }) = Just nm
+isCIPCan_Maybe _                = Nothing
+
+isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon
+isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
+isCFunEqCan_Maybe _ = Nothing
 
 \end{code}
 
@@ -331,6 +348,11 @@ isDerivedByInst :: CtFlavor -> Bool
 isDerivedByInst (Derived _ DerInst) = True 
 isDerivedByInst _                   = False 
 
+isWantedCt :: CanonicalCt -> Bool 
+isWantedCt ct = isWanted (cc_flavor ct)
+isGivenCt :: CanonicalCt -> Bool 
+isGivenCt ct = isGiven (cc_flavor ct) 
+
 canSolve :: CtFlavor -> CtFlavor -> Bool 
 -- canSolve ctid1 ctid2 
 -- The constraint ctid1 can be used to solve ctid2