[commit: ghc] wip/tc-plugins: Hook-in the plugins with the constraint solve in TcInteract (09e74f4)

[git at git.haskell.org]

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

On branch  : wip/tc-plugins
Link       : http://ghc.haskell.org/trac/ghc/changeset/09e74f4545cb37b1263217ac513191d20fc16939/ghc

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

commit 09e74f4545cb37b1263217ac513191d20fc16939
Author: Iavor S. Diatchki <diatchki at galois.com>
Date:   Wed Oct 8 16:10:51 2014 -0700

    Hook-in the plugins with the constraint solve in TcInteract


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

09e74f4545cb37b1263217ac513191d20fc16939
 compiler/typecheck/TcInteract.lhs | 74 ++++++++++++++++++++++++++++++++++++++-
 compiler/typecheck/TcSMonad.lhs   | 15 ++++++++
 2 files changed, 88 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 4948692..a881a40 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -118,12 +118,84 @@ solveInteract cts
         do { sel <- selectNextWorkItem max_depth
            ; case sel of
               NoWorkRemaining     -- Done, successfuly (modulo frozen)
-                -> return ()
+                -> do more_work <- runTcPlugins
+                      when more_work (solve_loop max_depth)
+
               MaxDepthExceeded cnt ct -- Failure, depth exceeded
                 -> wrapErrTcS $ solverDepthErrorTcS cnt (ctEvidence ct)
               NextWorkItem ct     -- More work, loop around!
                 -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
 
+
+-- | Try to make progress using type-checker plugings.
+-- Returns 'True' if we added some extra work to the work queue.
+runTcPlugins :: TcS Bool
+runTcPlugins =
+  do gblEnv <- getGblEnv
+     case tcg_tc_plugins gblEnv of
+       []      -> return False
+       plugins ->
+         do has_new_works <- mapM runPlugin plugins
+            return (or has_new_works)
+  where
+  runPlugin p =
+    do iSet <- getTcSInerts
+       let iCans    = inert_cans iSet
+           iEqs     = concat (varEnvElts (inert_eqs iCans))
+           iFunEqs  = funEqsToList (inert_funeqs iCans)
+           allCts   = iEqs ++ iFunEqs
+           (derived,other) = partition isDerivedCt allCts
+           (wanted,given)  = partition isWantedCt  other
+
+           -- We use this to remove some constraints.
+           -- 'survived' should be the sub-set of constraints that
+           -- remains inert.
+           restoreICans survived =
+             do let iCans1 = iCans { inert_eqs = emptyVarEnv
+                                   , inert_funeqs = emptyFunEqs }
+                    iCans2 = foldl addInertCan iCans1 derived
+                    iCans3 = foldl addInertCan iCans2 survived
+                setInertCans iCans3
+
+       result <- tcPluginIO $ tcPluginSolve p given wanted
+       case result of
+
+         TcPluginContradiction bad_cts ok_cts ->
+            do restoreICans ok_cts
+               mapM_ emitInsoluble bad_cts
+               return False
+
+         TcPluginNewWork new_cts ->
+            case removeKnownCts iCans new_cts of
+              [] -> return False
+              new_work ->
+                 do updWorkListTcS (extendWorkListCts new_work)
+                    return True
+
+         TcPluginSolved solved_cts other_cts ->
+            case solved_cts of
+              [] -> return False    -- Fast common case
+              _  -> do restoreICans other_cts
+                       let setEv (ev,ct) = setEvBind (ctev_evar (cc_ev ct)) ev
+                       mapM_ setEv solved_cts
+                       return False
+
+  removeKnownCts origIcans = filter (not . isKnownCt origIcans)
+  isKnownCt origIcans ct =
+    case ct of
+
+      CFunEqCan { cc_fun = f, cc_tyargs = ts } ->
+        case findFunEq (inert_funeqs origIcans) f ts of
+          Just _ -> True
+          _      -> False
+
+      CTyEqCan { cc_tyvar = x, cc_rhs = t } ->
+        not $ any (eqType t . cc_rhs) $ findTyEqs (inert_eqs origIcans) x
+
+      _ -> panic "TcPlugin returned not a TyEq or FunEq constraint"
+
+
+
 type WorkItem = Ct
 type SimplifierStage = WorkItem -> TcS StopOrContinue
 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 0f7fff8..c5d1b59 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -77,6 +77,7 @@ module TcSMonad (
 
     findDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
 
+    emptyFunEqs, funEqsToList,
     findFunEq, findTyEqs, 
     findFunEqsByTyCon, findFunEqs, partitionFunEqs,
     sizeFunEqMap,
@@ -90,6 +91,8 @@ module TcSMonad (
 
     getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
 
+    tcPluginIO,
+
     matchFam, 
     checkWellStagedDFun,
     pprEq                                    -- Smaller utils, re-exported from TcM
@@ -2013,3 +2016,15 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
         }
 \end{code}
 
+
+External Type-checker Plugins
+-----------------------------
+
+\begin{code}
+-- | Execute an IO action needed by an external plugin.
+tcPluginIO :: IO a -> TcS a
+tcPluginIO m = TcS (\_ -> liftIO m)
+\end{code}
+
+
+