[commit: ghc] supercompiler: Refactor in terms of terminateM combinator (9bce977)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/9bce977514e427396b1a7a73af3af331b1891307

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

commit 9bce977514e427396b1a7a73af3af331b1891307
Author: Max Bolingbroke <[email protected]>
Date:   Fri Nov 4 15:26:33 2011 +0000

    Refactor in terms of terminateM combinator

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

 .../supercompile/Supercompile/Drive/Process2.hs    |   19 ++++++++++++-------
 1 files changed, 12 insertions(+), 7 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs
index f86fc26..a9a2fba 100644
--- a/compiler/supercompile/Supercompile/Drive/Process2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process2.hs
@@ -152,6 +152,15 @@ runHistoryThreadM :: HistoryThreadM a -> a
 runHistoryThreadM = flip State.evalState pROCESS_HISTORY
 
 
+terminateM :: State -> RollbackScpM -> a -> (State -> RollbackScpM -> ProcessM (ProcessHistory, a)) -> ProcessM a
+terminateM state rb k_continue k_stop = withHistory' $ \hist -> case terminate hist (state, rb) of
+    Continue hist'                   -> return (hist', k_continue)
+    Stop (shallow_state, shallow_rb) -> k_stop shallow_state shallow_rb
+  where
+    withHistory' :: (ProcessHistory -> ProcessM (ProcessHistory, a)) -> ProcessM a
+    withHistory' act = lift State.get >>= \hist -> act hist >>= \(hist', x) -> lift (State.put hist') >> return x
+
+
 class MonadTrans t where
     lift :: Monad m => m a -> t m a
 
@@ -343,18 +352,14 @@ liftSpeculatedStateT speculated state k = StateT $ \s -> speculated state (\stat
 
 newtype RollbackScpM = RB { doRB :: forall c. LevelM (Deeds, Out FVedTerm) -> ProcessM c }
 
-withHistory' :: (ProcessHistory -> ProcessM (ProcessHistory, a)) -> ProcessM a
-withHistory' act = lift State.get >>= \hist -> act hist >>= \(hist', x) -> lift (State.put hist') >> return x
-
-
 sc' :: State -> ProcessM (LevelM (Deeds, Out FVedTerm))
 sc' state = callCC (\k -> try (RB k))
   where
     trce shallow_state = pprTraceSC "sc-stop" (pPrintFullState True shallow_state $$ pPrintFullState True state)
     try :: RollbackScpM -> ProcessM (LevelM (Deeds, Out FVedTerm))
-    try rb = withHistory' $ \hist -> case terminate hist (state, rb) of
-               Continue hist'                   ->                      return          (hist', liftSpeculatedStateT speculated state $ \state' -> split (reduce state') (delayStateT (delayReaderT delay) . sc))
-               Stop (shallow_state, shallow_rb) -> trce shallow_state $ doRB shallow_rb (maybe (split shallow_state) id (generalise (mK_GENERALISER shallow_state state) shallow_state) (delayStateT (delayReaderT delay) . sc))
+    try rb = terminateM state rb
+               (liftSpeculatedStateT speculated state $ \state' -> split (reduce state') (delayStateT (delayReaderT delay) . sc))
+               (\shallow_state shallow_rb -> trce shallow_state $ doRB shallow_rb (maybe (split shallow_state) id (generalise (mK_GENERALISER shallow_state state) shallow_state) (delayStateT (delayReaderT delay) . sc)))
 
 sc :: State -> MemoT ProcessM (LevelM (Deeds, Out FVedTerm))
 sc = memo sc' . gc -- Garbage collection necessary because normalisation might have made some stuff dead