[commit: ghc] wip/gadtpm: Added incremental interface for the term oracle (84b478a)

[git at git.haskell.org]

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

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/84b478af2c6fdcd03f81e78203fae1d54a63f336/ghc

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

commit 84b478af2c6fdcd03f81e78203fae1d54a63f336
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Tue Sep 1 07:44:03 2015 +0200

    Added incremental interface for the term oracle


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

84b478af2c6fdcd03f81e78203fae1d54a63f336
 compiler/deSugar/TmOracle.hs | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)

diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index dd57704..372c30f 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -21,6 +21,9 @@ module TmOracle
 , filterComplex
 , runPmPprM
 , pprPmExprWithParens
+
+-- Incremental version
+, solveSimplesIncr, initialIncrState
 ) where
 
 #include "HsVersions.h"
@@ -710,3 +713,24 @@ instance Outputable PmLit where
 instance Outputable PmExpr where
   ppr e = fst $ runPmPprM (pprPmExpr e) []
 
+
+-- ----------------------------------------------------------------------------
+
+initialIncrState :: ([ComplexEq], TmOracleEnv)
+initialIncrState = ([], ([], Map.empty))
+
+solveSimplesIncr :: ([ComplexEq], TmOracleEnv) -- residual & previous state
+                 -> [SimpleEq]                 -- what to solve
+                 -> Either Failure ([ComplexEq], TmOracleEnv)
+solveSimplesIncr (residual, (unhandled, mapping)) simples
+  =  runExcept (runStateT result (unhandled, mapping))
+  where
+    complex = map (applySubstSimpleEq mapping) simples ++ residual
+    result  = prepComplexEqM complex >>= iterateComplex
+
+applySubstSimpleEq :: PmVarEnv -> SimpleEq -> ComplexEq
+applySubstSimpleEq env (x,e2)
+  = case Map.lookup x env of
+      Just e1 -> (e1,          getValuePmExpr env e2)
+      Nothing -> (PmExprVar x, getValuePmExpr env e2)
+