[solve and simplify equality constraints
John Meacham <john@repetae.net>**20061027031236] hunk ./FrontEnd/Tc/Class.hs 72
+inHnf (IsEq t1 t2) = True
hunk ./FrontEnd/Tc/Class.hs 83
+reducePred h p@(IsEq t1 t2) = fail "reducePred" -- return [p]
hunk ./FrontEnd/Tc/Class.hs 100
+--entails h ps e@(IsEq {}) = error $ pprint (ps,e)
hunk ./FrontEnd/Tc/Class.hs 107
+bySuper h p@IsEq {} = [p]
hunk ./FrontEnd/Tc/Class.hs 183
+{-
+contextReduce :: Pred -> Tc [Pred]
+conetxtReduce (IsIn c t) = ans where
+    ans = do
+        t' <- evalType t
+        case fromTAp t' of
+            (TCon tycon,as) -> ...
+            t' -> return [IsIn c t']
+contextReduce (IsEq t1 t2) = do
+    t1 <- evalType t1
+    t2 <- evalType t2
+    -}
+
hunk ./FrontEnd/Tc/Class.hs 199
+    liftIO $ putStrLn $ "Asserting entailment: " ++ pprint (qs,ps)
hunk ./FrontEnd/Tc/Main.hs 4
-import List
+import Data.Graph(stronglyConnComp, SCC(..))
hunk ./FrontEnd/Tc/Main.hs 6
-import qualified Text.PrettyPrint.HughesPJ as P
+import List
hunk ./FrontEnd/Tc/Main.hs 9
-import Data.Graph(stronglyConnComp, SCC(..))
+import qualified Text.PrettyPrint.HughesPJ as P
hunk ./FrontEnd/Tc/Main.hs 18
-import FrontEnd.Tc.Monad
-import FrontEnd.Tc.Type
-import FrontEnd.Tc.Unify
-import Options
-import qualified FlagOpts as FO
-import qualified FlagDump as FD
-import Support.FreeVars
hunk ./FrontEnd/Tc/Main.hs 20
+import FrontEnd.Tc.Monad hiding(listenPreds)
+import FrontEnd.Tc.Type
+import FrontEnd.Tc.Unify
hunk ./FrontEnd/Tc/Main.hs 30
+import Options
+import Support.FreeVars
+import qualified FlagDump as FD
+import qualified FlagOpts as FO
hunk ./FrontEnd/Tc/Main.hs 36
+listenPreds = listenSolvePreds
hunk ./FrontEnd/Tc/Main.hs 679
+    sc <- evalFullType sc
hunk ./FrontEnd/Tc/Monad.hs 26
+    evalFullType,
hunk ./FrontEnd/Tc/Monad.hs 30
+    listenCPreds,
hunk ./FrontEnd/Tc/Monad.hs 107
+    constraints      :: [Constraint],
hunk ./FrontEnd/Tc/Monad.hs 296
-addPreds ps = Tc $ tell mempty { collectedPreds = ps }
+addPreds ps = do
+    sl <- getSrcLoc
+    Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ], constraints = [ Equality { constraintSrcLoc = sl, constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] }
hunk ./FrontEnd/Tc/Monad.hs 300
+addConstraints :: [Constraint] -> Tc ()
+addConstraints ps = Tc $ tell mempty { constraints = ps }
hunk ./FrontEnd/Tc/Monad.hs 305
+
+listenCPreds :: Tc a -> Tc (a,(Preds,[Constraint]))
+listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $ listens (\x -> (collectedPreds x,constraints x)) action
+
hunk ./FrontEnd/Tc/Monad.hs 413
+evalFullType t = f' t where
+    f t = tickleM f' t
+    f' t =  evalType t >>= f
hunk ./FrontEnd/Tc/Monad.hs 417
-evalTAssoc TAssoc { typeCon = Tycon { tyconName = n1 }, typeClassArgs = [carg], typeExtraArgs = eas }  | (TCon Tycon { tyconName = n2 }, as) <- fromTAp carg = do
-    InstanceEnv ie <- asks tcInstanceEnv
-    case Map.lookup (n1,n2) ie of
-        Just (aa,bb,tt) -> return (applyTyvarMap (fromList $ zip aa as ++ zip bb eas) tt)
-        _ -> fail "no instance for associated type"
+evalTAssoc ta@TAssoc { typeCon = Tycon { tyconName = n1 }, typeClassArgs = ~[carg], typeExtraArgs = eas }  = do
+    carg' <- evalType carg
+    case fromTAp carg' of
+        (TCon Tycon { tyconName = n2 }, as) -> do
+            InstanceEnv ie <- asks tcInstanceEnv
+            case Map.lookup (n1,n2) ie of
+                Just (aa,bb,tt) -> return (applyTyvarMap (fromList $ zip aa as ++ zip bb eas) tt)
+                _ -> fail "no instance for associated type"
+        _ -> return ta { typeClassArgs = [carg'] }
hunk ./FrontEnd/Tc/Type.hs 20
+    Constraint(..),
hunk ./FrontEnd/Tc/Type.hs 34
+import FrontEnd.SrcLoc
hunk ./FrontEnd/Tc/Type.hs 55
+data Constraint = Equality {
+    constraintSrcLoc :: SrcLoc,
+    constraintType1 :: Type,
+    constraintType2 ::Type
+    }
+
+instance HasLocation Constraint where
+    srcLoc Equality { constraintSrcLoc = sl } = sl
+
hunk ./FrontEnd/Tc/Unify.hs 2
-module FrontEnd.Tc.Unify(subsumes,boxyMatch) where
+module FrontEnd.Tc.Unify(
+    subsumes,
+    boxyMatch,
+    listenSolvePreds
+    ) where
hunk ./FrontEnd/Tc/Unify.hs 18
+import FrontEnd.SrcLoc
hunk ./FrontEnd/Tc/Unify.hs 89
+
+
+    -- ASSOC
+    sub s1@TAssoc {} s2 = do
+        printRule "ASSOC"
+        s1 `boxyMatch` s2
+        return ctId
+
hunk ./FrontEnd/Tc/Unify.hs 214
+    -- Associated type
+    bm ta@TAssoc {} (TMetaVar mv) = do
+        printRule "ASSOC-BIND"
+        -- are associated types tau?
+        varBind mv ta
+        return False
+
+    bm ta@TAssoc {} tb@TAssoc {} = do
+        ta' <- evalFullType ta
+        tb' <- evalFullType tb
+        when (ta' /= tb') $ do
+            printRule "ASSOC-EQ"
+            addPreds [IsEq ta' tb']
+        return False
+
+    bm ta@TAssoc {} t = do
+        printRule "ASSOC-EQ"
+        -- are associated types tau?
+        addPreds [IsEq ta t]
+        return False
+
hunk ./FrontEnd/Tc/Unify.hs 241
+
+solveConstraints :: [Constraint] -> Tc ()
+solveConstraints cs = mapM_ f cs where
+    f Equality { constraintSrcLoc = _sl, constraintType1 = t1, constraintType2 = t2 } = {- withSrcLoc sl $ -} boxyMatch t1 t2
+
+listenSolvePreds :: Tc a -> Tc (a,[Pred])
+listenSolvePreds tc = do
+    (x,(ps,cs)) <- listenCPreds tc
+    ((),(ps',cs')) <- listenCPreds (solveConstraints cs)
+    ch <- getClassHierarchy
+    return (x,simplify ch (ps ++ ps') ++ [ IsEq a b | Equality _ a b <- cs' ])
+
+
hunk ./FrontEnd/Tc/Unify.hs 303
-unifyList :: [Type] -> Tc ()
-unifyList (t1:t2:ts) = unify t1 t2 >> unifyList (t2:ts)
-unifyList _ = return ()
hunk ./FrontEnd/Tc/Unify.hs 309
+