[commit: ghc] wip/ext-solver: A function for working with external constraints in bulk. (ca2721e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/ext-solver
Link       : http://ghc.haskell.org/trac/ghc/changeset/ca2721e84f2aa373361d5360922e7149d0602ded/ghc

>---------------------------------------------------------------

commit ca2721e84f2aa373361d5360922e7149d0602ded
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Thu May 8 08:54:27 2014 -0700

    A function for working with external constraints in bulk.


>---------------------------------------------------------------

ca2721e84f2aa373361d5360922e7149d0602ded
 compiler/typecheck/TcTypeNats.hs | 33 +++++++++++++++++++++++++++++++--
 1 file changed, 31 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index c7d2a25..4144906 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -932,8 +932,11 @@ solverImproveModel proc viRef imps =
           then varEq x ((x, e) : imps)        more  ys
           else varEq x           imps  (def : more) ys
 
-
-solverNewWork :: SolverProcess -> IORef VarInfo -> CtLoc -> Bool -> IO ExtSolRes
+-- Examine the current state of the solver and compute new work.
+solverNewWork :: SolverProcess -> IORef VarInfo
+              -> CtLoc      -- Source of the new constraints
+              -> Bool       -- Should generate givens?
+              -> IO ExtSolRes
 solverNewWork proc viRef loc withEv =
   do status <- solverCheck proc
      case status of
@@ -949,6 +952,32 @@ solverNewWork proc viRef loc withEv =
                                        $ mkNewFact loc withEv (mkTyVarTy tv, ty)
             return $ ExtSolOk $ mapMaybe toCt imps
 
+-- Check a list of constraints for consistency, and computer derived work.
+-- Assumes that all constraints are given or all are not given.
+solverImprove :: SolverProcess -> IORef VarInfo
+              -> [Ct] -> IO ExtSolRes
+solverImprove proc viRef cts =
+  do let (ours, ourCts) =
+            unzip [ (rep,ct) | ct <- cts, Just rep <- [ knownCt ct ] ]
+     case ourCts of
+       [] -> return (ExtSolOk [])
+       oneOfOurs : _ ->
+         do solverPush proc viRef
+            mapM_ assume ours
+            let loc = ctLoc oneOfOurs -- XXX: What is a better location?
+
+            -- XXX: When we compute improvements,
+            -- we should probably limit ourselves to compute improvements
+            -- only for the variables in the current scope.
+            res <- solverNewWork proc viRef loc (isGivenCt oneOfOurs)
+            solverPop proc viRef
+            return res
+  where
+  assume (vars,expr) =
+     do mapM_ (solverDeclare proc viRef) (eltsUFM vars)
+        solverAssume proc expr
+
+
 
 smtTy :: Ty -> SExpr
 smtTy ty =