Commit a258aefc authored by kristenk's avatar kristenk
Browse files

Solver: Use difference lists to combine logs in 'Explore.exploreLog'.

This commit adds a data structure, 'RetryLog', which is like a difference list
for the 'Progress' type, except that it only supports efficient appends at
failures. Since the solver continually appends logs and calls 'tryWith' while
exploring the search tree, it is important for those operations to be efficient.
Afterwards, the solver converts the 'RetryLog' back to a 'Progress' so that it
can be processed with pattern matching in Log.hs and Message.hs.
parent a92bfc8d
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular.Explore
( backjump
, backjumpAndExplore
......@@ -13,6 +14,7 @@ import Distribution.Solver.Modular.Log
import Distribution.Solver.Modular.Message
import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))
......@@ -47,24 +49,20 @@ backjump :: EnableBackjumping -> Var QPN
backjump (EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
where
combine :: (ConflictMap -> ConflictSetLog a)
combine :: forall a . (ConflictMap -> ConflictSetLog a)
-> (ConflictSet QPN -> ConflictMap -> ConflictSetLog a)
-> ConflictSet QPN -> ConflictMap -> ConflictSetLog a
combine x f csAcc cm =
let l = x cm
in case l of
P.Done d -> P.Done d
P.Fail (cs, cm')
| enableBj && not (var `CS.member` cs) -> logBackjump cs cm'
| otherwise -> f (csAcc `CS.union` cs) cm'
P.Step m ms ->
let l' = combine (\ _ -> ms) f csAcc cm
in P.Step m l'
combine x f csAcc cm = retry (x cm) next
where
next :: (ConflictSet QPN, ConflictMap) -> ConflictSetLog a
next (cs, cm')
| enableBj && not (var `CS.member` cs) = logBackjump cs cm'
| otherwise = f (csAcc `CS.union` cs) cm'
logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a
logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm)
type ConflictSetLog = P.Progress Message (ConflictSet QPN, ConflictMap)
type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap)
type ConflictMap = Map (Var QPN) Int
......@@ -167,7 +165,8 @@ backjumpAndExplore :: EnableBackjumping
-> CountConflicts
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj countConflicts t =
toLog $ (exploreLog enableBj countConflicts t (A M.empty M.empty M.empty)) M.empty
toLog $ toProgress $
exploreLog enableBj countConflicts t (A M.empty M.empty M.empty) M.empty
where
toLog :: P.Progress step fail done -> Log step done
toLog = P.foldProgress P.Step (const (P.Fail ())) P.Done
module Distribution.Solver.Modular.Log
( Log
, continueWith
, failWith
, logToProgress
, succeedWith
, tryWith
) where
import Control.Applicative
......@@ -90,17 +86,3 @@ logToProgress mbj l = let
currlimit Nothing = ""
go _ _ (Done s) = Done s
go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
failWith :: step -> fail -> Progress step fail done
failWith s f = Step s (Fail f)
succeedWith :: step -> done -> Progress step fail done
succeedWith s d = Step s (Done d)
continueWith :: step -> Progress step fail done -> Progress step fail done
continueWith = Step
tryWith :: Message
-> Progress Message fail done
-> Progress Message fail done
tryWith m = Step m . Step Enter . foldProgress Step (failWith Leave) Done
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular.RetryLog
( RetryLog
, toProgress
, fromProgress
, retry
, failWith
, succeedWith
, continueWith
, tryWith
) where
import Distribution.Solver.Modular.Message
import Distribution.Solver.Types.Progress
-- | 'Progress' as a difference list that allows efficient appends at failures.
newtype RetryLog step fail done = RetryLog {
unRetryLog :: (fail -> Progress step fail done)
-> Progress step fail done
}
-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.
toProgress :: RetryLog step fail done -> Progress step fail done
toProgress (RetryLog f) = f Fail
-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.
fromProgress :: forall step fail done .
Progress step fail done
-> RetryLog step fail done
fromProgress l = RetryLog $ \f ->
let go :: Progress step fail done -> Progress step fail done
go (Done d) = Done d
go (Fail failure) = f failure
go (Step m ms) = Step m (go ms)
in go l
-- | /O(1)/. If the first log leads to failure, continue with the second.
retry :: RetryLog step fail done
-> (fail -> RetryLog step fail done)
-> RetryLog step fail done
retry (RetryLog f) g =
RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog
-- | /O(1)/. Create a log with one message before a failure.
failWith :: step -> fail -> RetryLog step fail done
failWith m failure = RetryLog $ \f -> Step m (f failure)
-- | /O(1)/. Create a log with one message before a success.
succeedWith :: step -> done -> RetryLog step fail done
succeedWith m d = RetryLog $ const $ Step m (Done d)
-- | /O(1)/. Prepend a message to a log.
continueWith :: step
-> RetryLog step fail done
-> RetryLog step fail done
continueWith m (RetryLog f) = RetryLog $ Step m . f
-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert
-- 'Leave' before the failure if the log fails.
tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done
tryWith m f =
RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))
......@@ -298,6 +298,7 @@ executable cabal
Distribution.Solver.Modular.Package
Distribution.Solver.Modular.Preference
Distribution.Solver.Modular.PSQ
Distribution.Solver.Modular.RetryLog
Distribution.Solver.Modular.Solver
Distribution.Solver.Modular.Tree
Distribution.Solver.Modular.Validate
......@@ -391,6 +392,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.JobControl
UnitTests.Distribution.Client.InstallPlan
UnitTests.Distribution.Solver.Modular.PSQ
UnitTests.Distribution.Solver.Modular.RetryLog
UnitTests.Distribution.Solver.Modular.Solver
UnitTests.Distribution.Solver.Modular.DSL
UnitTests.Options
......
......@@ -12,6 +12,7 @@ import Distribution.Compat.Time
import qualified UnitTests.Distribution.Solver.Modular.PSQ
import qualified UnitTests.Distribution.Solver.Modular.Solver
import qualified UnitTests.Distribution.Solver.Modular.RetryLog
import qualified UnitTests.Distribution.Client.FileMonitor
import qualified UnitTests.Distribution.Client.Glob
import qualified UnitTests.Distribution.Client.GZipUtils
......@@ -39,6 +40,8 @@ tests mtimeChangeCalibrated =
UnitTests.Distribution.Solver.Modular.PSQ.tests
, testGroup "UnitTests.Distribution.Solver.Modular.Solver"
UnitTests.Distribution.Solver.Modular.Solver.tests
, testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"
UnitTests.Distribution.Solver.Modular.RetryLog.tests
, testGroup "UnitTests.Distribution.Client.FileMonitor" $
UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
, testGroup "UnitTests.Distribution.Client.Glob"
......
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.Solver.Modular.RetryLog (
tests
) where
import Distribution.Solver.Modular.Message
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Types.Progress
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase, (@?=))
type Log a = Progress a String String
tests :: [TestTree]
tests = [
testCase "convert to and from RetryLog ending in failure" $
let lg = Step 1 (Step 2 (Step 3 (Fail "Error")))
in toProgress (fromProgress lg) @?= (lg :: Log Int)
, testCase "convert to and from RetryLog ending in success" $
let lg = Step 1 (Step 2 (Step 3 (Done "Result")))
in toProgress (fromProgress lg) @?= (lg :: Log Int)
, testCase "retry with failure" $
let log1 = fromProgress $ Step 1 (Step 2 (Fail "Error 1"))
log2 = fromProgress $ Step 3 (Step 4 (Fail "Error 2"))
in toProgress (retry log1 (const log2))
@?= (Step 1 (Step 2 (Step 3 (Step 4 (Fail "Error 2")))) :: Log Int)
, testCase "retry with success" $
let lg1 = fromProgress $ Step 1 (Step 2 (Done "Done"))
lg2 = fromProgress $ Step 3 (Step 4 (Fail "Error"))
in toProgress (retry lg1 (const lg2))
@?= (Step 1 (Step 2 (Done "Done")) :: Log Int)
, testCase "failWith" $
toProgress (failWith 1 "Error") @?= (Step 1 (Fail "Error") :: Log Int)
, testCase "succeedWith" $
toProgress (succeedWith 1 "Result")
@?= (Step 1 (Done "Result") :: Log Int)
, testCase "continueWith" $
let failure = Fail "Error"
in toProgress (continueWith 1 $ fromProgress failure)
@?= (Step 1 failure :: Log Int)
, testCase "tryWith with failure" $
let failure = Fail "Error"
s = Step Success
in toProgress (tryWith Success $ fromProgress (s (s failure)))
@?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)
, testCase "tryWith with success" $
let done = Done "Done"
s = Step Success
in toProgress (tryWith Success $ fromProgress (s (s done)))
@?= (s (Step Enter (s (s done))) :: Log Message)
]
deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)
deriving instance (Show step, Show fail, Show done)
=> Show (Progress step fail done)
deriving instance Eq Message
deriving instance Show Message
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment