[darcs-devel] conflicted rebase (or rather: rebase with conflicted fixups)
Ben Franksen
ben.franksen at online.de
Mon May 25 23:09:03 UTC 2020
Am 25.05.20 um 13:30 schrieb Ben Franksen:
> To restore the previous behavior here, that is, to make duplicate fixups
> conflicting with the suspended patches for V1 and V2, we'd have to add
> the original PatchInfo to all "prim" fixups. When we merge such a fixup
> with a ToEdit named patch, we first turn it into a pseudo named patch
> (using the stored name, no dependencies, and the single RepoPatch we
> have) and then merge that with the suspended ToEdit patch. The overhead
> of storing (and using) the extra PatchInfo would be wasted for V3, but I
> guess that's the price to pay. BTW, upgrading rebase "0.0" would then
> require the use of Darcs.Patch.Named.anonymous instead of fromAnonymousPrim.
For completeness, I have implemented this, though I am not convinced it
the strictly better behavior. I have attached the latest version as a
single large bundle against reviewed.
Cheers
Ben
-------------- next part --------------
57 patches for repository http://darcs.net/reviewed:
patch 9e9c1c5e2c6b23632605a5885d958b3cd3e20bb1
Author: Ben Franksen <ben.franksen at online.de>
Date: Tue Apr 28 08:54:21 CEST 2020
* replace runhaskell with runghc in tests/renames.sh
It seems runghc is better supported by ghc packagers than runhaskell. This
is not a complete solution, though. If cabal is used with
--with-compiler=/path/to/ghc, there is no guarantee that we have a runghc or
a runhaskell in the PATH.
patch 10bcc43af5991b468a15df0ef32948dec94fa1ce
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Fri Jan 31 18:18:36 CET 2020
* remove obsolete comment
patch 66f3f4db8029b85908991cd4c579e8da9bb02b34
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 1 22:51:22 CET 2020
* tests: add fail method to instance Monad Fail
This is needed for now in the MonadFail transition
patch dcb740c4e786947684f1f75480ccba930f5d4958
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Fri Feb 7 23:48:17 CET 2020
* tests: add Shrinkable class
patch 117d1ead1a2b3c9ea0e90d4697c6137b9b58babb
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 8 18:25:42 CET 2020
* tests: introduce concept of shrinking models
patch a463e7477e459d3cad5dfa32d286ab3efd759952
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 9 01:22:38 CET 2020
* shrinking names and file content
patch ad0998a95bf7c7e09b29f5a1d7397ffb92de5e64
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 9 20:31:31 CET 2020
* tests: introduce an explicit MergeableSequence type
patch 054b211cef28d017955dc69f027a3e8689a07b33
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 9 20:52:24 CET 2020
* tests: add PropagateShrink and Effect for MergeableSequence
patch 9ec8b17389f2244302878945b17e26efdf3e118b
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 9 23:39:23 CET 2020
* tests: better shrinking for MergeableSequence.ParMS
patch 2c4ba63f5a588168fa52facc3301318fb9365bee
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Wed Feb 12 14:01:52 CET 2020
* tests: add some more comments about ShrinkModel/PropagateShrink
patch f689ef5149917e8951938c1b25e29a7c5dec0e7f
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 15:21:25 CET 2020
* tests: remove invalid TODO
many of the uses of WithStartState are with single-parameter patches
like Tree so can't be easily replaced by WithStartState2.
patch 747d75e19cc3652e62db5ef91b2c7b27f2759619
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 15:36:32 CET 2020
* tests: sort default-extensions
patch af16ca9f2636931774686e8f12d556c5048d234f
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 15:40:40 CET 2020
* tests: add DefaultSignatures to .cabal file
patch d69117711c7e7c89393176cfc224b9c71fcf743f
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 15:55:42 CET 2020
* tests: remove some redundant LANGUAGE pragmas
patch 2df3c52bfa260cc15c7a6a7eff245eb10938d611
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 15:56:35 CET 2020
* tests: list MultiParamTypeClasses in the cabal file
It's very widely used in the tests and generally we wouldn't
think twice about using it in test code/infrastructure.
patch 7a415dccdb33e436a098e86ec4101525d0518bf5
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 16:18:04 CET 2020
* tests: remove unnecessary UndecidableInstances
patch 2fc94901ecea15189ddb1f0c41e26db51533580b
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 18:12:59 CET 2020
* tests: NoMonoLocalBinds needs to come last
patch b2d90359fa8a5abe3fb1d9aae89b7f067a22b1d7
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 17:56:49 CET 2020
* tests: correct mistake in MultiParamTypeClasses patch
I accidentally removed UndecidableInstances when resolving a
local conflict.
patch b7b03658ee2260354916d101b169e6fd84998c56
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Fri Feb 14 07:51:31 CET 2020
* specialise the types of withSingle etc
The new types reflect their actual usage and will make it
easier to move logic around.
patch 2f1631f5733447e28a0c529ecd47523d4edafff7
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sat Feb 15 10:29:21 CET 2020
* use the shrinking for MergeableSequence on existing tests
patch 26ffb61437f21157b4fac3e55c841cf152559f40
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun Feb 16 09:53:32 CET 2020
* massive boilerplate reduction in test harness
This patch makes a number of invasive refactors in the test harness that
dramatically reduce the boilerplate of repeated instance Arbitrary
definitions. Here are the main ideas:
First, remove all instances for Sealed patches and keep only the ones for
Sealed2 patches. The generators and infrastructure have been refactored to
always take and generate Sealed2 patches. This has the beneficial
side-effect of cleaning up a lot of the types in the testing infrastructure.
For most of the remaining Arbitrary instances we can provide a single
generic instance. To make this possible we need to use the generic model
generator (aSmallRepo from the RepoModel class), which we always do except
for the RepoPatchV1 tests. My solution for this was to move all the
RepoPatchV1 tests into a separate module and throw out the tests that are
disabled for RepoPatchV1 anyway. Even with this out of the way, I needed to
refactor WithState and the class ArbitraryState to no longer take the
model/state as parameter, but rather use the type function ModelOf. This,
too, make the types simpler and signatures less verbose.
Additional minor cleanups:
- The TestGenerator/TestCondition/TestCheck machinery now lives in the
D.T.Patch.Utils module.
- Generalize qc_prim32/3 to qc_named_prim.
- Removed some redundant constraints.
- Renamed Darcs.Test.Util.TestResult.fromMaybe to avoid collision with the
well known Data.Maybe.fromMaybe
- Allow all darcs-lib extensions for darcs-test, too; cleanup module-local
extension pragmas.
patch 3907522903f464fde175ffc74599224464f12400
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun Feb 16 20:03:23 CET 2020
* harness: move legacy Tree stuff into its own module
D.T.P.Arbitrary.Generic has grown quite a lot with the new shrinker, so it
makes sense to split it. Besides this gets the old Tree based generator out
of the way, making it easier to eventually get rid of it.
patch b25ff3a8e8d286dedc2a227b11967fdc6e97fd9f
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Wed Feb 19 23:36:03 CET 2020
* tests: GHC 8.6 requires a couple of UndecidableInstances
patch 53431782f9901daf6fd88a667cc2818f466f8eed
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Thu Feb 20 18:34:09 CET 2020
* add comments about why UndecidableInstances is needed
patch b043d8bcbbe106224a90148480f9735ab0bfefc3
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 11:58:34 CET 2020
* tests: always use prim patches for generating/shrinking
We already didn't try to generate conflicted patches, and
even shrinking unconflicted patches is actually unsound if
there might be a conflict later in a sequence.
Instead of needing partial functions on repo patches, it's
better to express this invariant in the types by only storing
prim patches, and generating the repo patches on the fly
when actually using the test cases.
patch ba02c674facfc9dfc826adc1eb8509e07fe010c0
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 13:06:59 CET 2020
* tests: introduce infrastructure for merge checking
Because V1 and V2 patches are known to be buggy, we
sometimes need to exclude buggy merges when using them
to test other properties.
patch b55922b9b19e27d3d42cf4c500d2c9e17e24e9d5
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:44:20 CET 2020
* tests: export V1Model(..)
patch a12d103d29765fab991507c7a95eae9953e0c64e
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun Feb 16 20:20:13 CET 2020
* harness: remove propIsMergeable
This test is completely redundant. It merely checks whether flattening a
Tree of patches crashes. We test this much more thoroughly with the other
merge tests.
patch 3dc6fb02adcabbba69bc02decb322fec09bab80a
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:48:06 CET 2020
* tests: move patch properties into D.T.P.P.Generic
This means they can be used from D.T.P.RepoPatchV1
patch f2a716c01d4ca6197a45ac9aaf0c1957006c17af
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun Feb 16 19:21:20 CET 2020
* remove state parameter from WithStartState2
This is similar to what I did to WithState and has the same advantages.
patch 6f7b4b6bd8785c0f4df3bf587c1ac1df1149d576
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:51:48 CET 2020
* tests: remove unused withStateShrinking
patch 4b0e6e70e1c73391b5ad787c88b47cf330ff6a29
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:52:48 CET 2020
* tests: generalise hasPrimConstruct, add usesV1Model
patch c26d508c17fc6157325cea574118adace10ba083
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:52:54 CET 2020
* tests: introduce method to identify V1 patch type
patch fa5773462abc1d2d4fc79429f43afe62574910e2
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Sun Feb 23 19:54:42 CET 2020
* tests: add withAllSequenceItems
patch 54bb5860e199e30c8f4ae1e67165032c943586f3
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Tue Feb 25 08:09:02 CET 2020
* tests: add a TODO about merging hasPrimConstruct/usesV1Model
patch 9a237fb212d148f7103d0ce5028cc68b600a2bba
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Tue Feb 25 08:34:38 CET 2020
* tests: add mappend TestResult for old GHC compatibility
patch 9ac310184b6f612d6da4946c2e91b3a4f356e967
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Tue Feb 25 09:04:53 CET 2020
* tests: use Semigroup TestResult consistently
patch 52ab292bb7327443a6f85b38ebcd7b2fa810a054
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Tue Mar 3 14:21:32 CET 2020
* update indentation of instance ShowPatchBasic RebaseChange
patch 2d1384ec6f038368c442d1bdbe06de8543470006
Author: Ganesh Sittampalam <ganesh at earth.li>
Date: Thu Mar 5 08:04:13 CET 2020
* cut back some constraints on RebaseChange instances
This is primarily to make future refactoring easier.
patch a633b62649f61049e0d870eec51e140f038c474b
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 14:18:47 CEST 2020
* remove an obsolete TODO comment
patch e05e56f109f827ec43ac99db57a7bf21c59d36d4
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 13:59:48 CEST 2020
* conflicted rebase: first steps
patch 2b4b580edca2c62ea95ed3f432a0cbcb4c339f87
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:48:09 CEST 2020
* use pager to display 'darcs rebase log'
patch 775709e7c529ac406d02e2854e1fe24fdef7bc94
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 23:39:00 CEST 2020
* fix rebase unsuspend after rebase changes
patch f5741f046f773ea9858f2c1ac5bb49aae823907d
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 23:37:08 CEST 2020
* fix Darcs.Patch.Rebase.Viewing.partitionUnconflicted
patch edc5cb8be694432738fe0a212d3f9de2a725072b
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 23:43:19 CEST 2020
* fix amend after rebase changes
patch 53c183a83dd9a49503b8fb48fb813430cca9dfe7
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 14:17:41 CEST 2020
* remove 'rebase inject' command
With the new conflicted rebase implementation it no longer makes sense to
have this command, since all fixups will be injected anyway on unsuspend.
patch 0cef8aec48dcd9998833e7cdc2db94bf1b9162ff
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:17:29 CEST 2020
* tests/rebase-apply.sh: add extra debug logs
patch d1986ddee23a674645255ae32852df64d1dea8f9
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:18:16 CEST 2020
* tests/rebase-apply.sh: fix expected conflict markup
patch 59a846a426eb90a771655f0939d905e1f6938e0e
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:19:05 CEST 2020
* tests/rebase-changes.sh: fix expected log output
patch 083b11fa43ad997d67d24e62814afab2682b021e
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:19:48 CEST 2020
* add two tests for rebase of conflicted patches
patch 8b33cf9afed2bb17424c04c8201ecbff2dd2aed1
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:20:53 CEST 2020
* tests/rebase-keeps-deps-on-amend.sh: add extra debug logs
patch 9cd020a1187ae3705a0d6ac129fdcf4d80bb7c03
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:22:02 CEST 2020
* tests/rebase-keeps-deps-on-amend.sh: remove redundant options
patch 43044a28ad9b3dd0f4e4f120fa16e95bab075bff
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:23:22 CEST 2020
* tests/rebase-pull.sh: fix expected conflict markup
patch 79dcde1117eafc8397524b4c4d2eb6c2bc880b9e
Author: Ben Franksen <ben.franksen at online.de>
Date: Sun May 24 17:24:02 CEST 2020
* tests/rebase-repull.sh: extend with more tests and debugging
patch 590039225e19d08f883da7f8abfa45bb643731ed
Author: Ben Franksen <ben.franksen at online.de>
Date: Sat May 23 13:58:00 CEST 2020
* harness: disable duplicateConflictedEffect test
It is questionable whether this test makes any sense at all with the
conflicted rebase.
patch 663274754f91ef26341a811edabb6cf4987b2f1c
Author: Ben Franksen <ben.franksen at online.de>
Date: Mon May 25 10:57:28 CEST 2020
* add atomatic upgrade from rebase version "0.0"
This upgrade simply uses fromAnonymousPrim to upgrade prim fixups to patch
fixups.
patch e9c25d7d218b46c2986b8f2a29320db257aa02b7
Author: Ben Franksen <ben.franksen at online.de>
Date: Mon May 25 20:06:48 CEST 2020
* store original patch name together with fixup
This is so we can distinguish between fixups and patches inside suspended
named patches when they are content-wise equal i.e. duplicates.
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA256
New patches:
[replace runhaskell with runghc in tests/renames.sh
Ben Franksen <ben.franksen at online.de>**20200428065421
Ignore-this: 751c373b0af77d48dd0383d56c23454f51185014eabb82dcf90329905e97c90f29c85636b88fe2b
It seems runghc is better supported by ghc packagers than runhaskell. This
is not a complete solution, though. If cabal is used with
--with-compiler=/path/to/ghc, there is no guarantee that we have a runghc or
a runhaskell in the PATH.
] hunk ./tests/renames.sh 29
- -runhaskell $TESTBIN/renameHelper.hs
+runghc $TESTBIN/renameHelper.hs
[remove obsolete comment
Ganesh Sittampalam <ganesh at earth.li>**20200131171836
Ignore-this: 88fadb6e21899e49f586973f36a8cd94
] hunk ./harness/Darcs/Test/Patch/WithState.hs 91
- - -- does a coarbitrary make sense?
- -
[tests: add fail method to instance Monad Fail
Ganesh Sittampalam <ganesh at earth.li>**20200201215122
Ignore-this: 69b7c7a2a56ce922061ea610561e91cc
This is needed for now in the MonadFail transition
] hunk ./harness/Darcs/Test/Patch/RepoModel.hs 28
+ fail = Failed
[tests: add Shrinkable class
Ganesh Sittampalam <ganesh at earth.li>**20200207224817
Ignore-this: e874b19b45a593966e1a4704a26c1c41
] hunk ./darcs.cabal 590
+ Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch.hs 64
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch.hs 285
+ , Shrinkable p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 9
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 12
+import Darcs.Patch.Commute
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 17
+import Control.Applicative ( (<|>) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 31
+instance (Commute p, Shrinkable p) => Shrinkable (Named p) where
+ shrinkInternally (NamedP pi deps ps) =
+ -- TODO this isn't quite right because other patches might
+ -- explicitly depend on this one
+ (\pi' -> NamedP pi' deps ps) <$> shrink pi
+ <|>
+ NamedP pi deps <$> shrinkInternally ps
+
+ shrinkAtStart (NamedP pi deps ps) = mapFlipped (NamedP pi deps) <$> shrinkAtStart ps
+ shrinkAtEnd (NamedP pi deps ps) = mapSeal (NamedP pi deps) <$> shrinkAtEnd ps
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 49
+import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 117
+instance Shrinkable (RepoPatchV1 prim) where
+ shrinkInternally _ = []
+ shrinkAtStart _ = []
+ shrinkAtEnd _ = []
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 4
+import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 14
+instance Shrinkable (RepoPatchV2 prim) where
+ shrinkInternally _ = []
+ shrinkAtStart _ = []
+ shrinkAtEnd _ = []
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 7
+import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 16
+instance Shrinkable (RepoPatchV3 prim) where
+ shrinkInternally _ = []
+ shrinkAtStart _ = []
+ shrinkAtEnd _ = []
addfile ./harness/Darcs/Test/Patch/Arbitrary/Shrink.hs
hunk ./harness/Darcs/Test/Patch/Arbitrary/Shrink.hs 1
+module Darcs.Test.Patch.Arbitrary.Shrink
+ ( Shrinkable(..)
+ ) where
+
+import Darcs.Prelude
+
+import Darcs.Patch.Commute
+import Darcs.Patch.Permutations
+
+import Darcs.Patch.Witnesses.Ordered
+import Darcs.Patch.Witnesses.Sealed
+
+-- |This class encapsulates the general concept of shrinking a patch
+-- without using any information about the repository state the
+-- patch is applied to.
+class Shrinkable p where
+ -- |Shrink a patch while preserving the start and end contexts.
+ shrinkInternally :: p wX wY -> [p wX wY]
+ -- |Shrink a patch, preserving the start context, but maybe not the end context.
+ shrinkAtEnd :: p wX wY -> [Sealed (p wX)]
+ -- |Shrink a patch, preserving the end context, but maybe not the start context.
+ shrinkAtStart :: p wX wY -> [FlippedSeal p wY]
+
+instance (Shrinkable p, Shrinkable q) => Shrinkable (p :> q) where
+ shrinkInternally (p :> q) =
+ ((:> q) <$> shrinkInternally p) ++
+ ((p :>) <$> shrinkInternally q)
+ shrinkAtEnd (p :> q) = do
+ Sealed q' <- shrinkAtEnd q
+ return (Sealed (p :> q'))
+ shrinkAtStart (p :> q) = do
+ FlippedSeal p' <- shrinkAtStart p
+ return (FlippedSeal (p' :> q))
+
+instance (Commute p, Shrinkable p) => Shrinkable (FL p) where
+ shrinkInternally NilFL = []
+ shrinkInternally (p :>: ps) =
+ ((:>: ps) <$> shrinkInternally p) ++ ((p :>: ) <$> shrinkInternally ps)
+
+ shrinkAtStart ps = do
+ q :> qs <- headPermutationsFL ps
+ FlippedSeal qs:map (mapFlipped (:>: qs)) (shrinkAtStart q)
+
+ shrinkAtEnd = map (mapSeal reverseRL) . shrinkAtEnd . reverseFL
+
+instance (Commute p, Shrinkable p) => Shrinkable (RL p) where
+ shrinkInternally = map reverseFL . shrinkInternally . reverseRL
+
+ shrinkAtStart = map (mapFlipped reverseFL) . shrinkAtStart . reverseRL
+
+ shrinkAtEnd ps = do
+ qs :<: q <- headPermutationsRL ps
+ Sealed qs:map (mapSeal (qs :<:)) (shrinkAtEnd q)
[tests: introduce concept of shrinking models
Ganesh Sittampalam <ganesh at earth.li>**20200208172542
Ignore-this: 1ab8bd721379b43de6bb4787e344cd2b
] hunk ./harness/Darcs/Test/Patch.hs 66
- -import Darcs.Test.Patch.WithState( WithState, WithStartState, WithStartModel )
+import Darcs.Test.Patch.WithState
+ ( WithState, WithStartState, WithStartModel
+ , ShrinkModel, PropagateShrink
+ )
hunk ./harness/Darcs/Test/Patch.hs 244
+ , ShrinkPrim prim
hunk ./harness/Darcs/Test/Patch.hs 270
+ , ShrinkPrim prim
hunk ./harness/Darcs/Test/Patch.hs 293
+ , ShrinkModel (ModelOf (PrimOf p)) (PrimOf p)
+ , PropagateShrink (PrimOf p) p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 8
+ , ShrinkPrim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 227
+type ShrinkPrim prim =
+ ( ShrinkModel (ModelOf prim) prim
+ , PropagateShrink prim prim
+ )
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 15
+import Darcs.Patch.Witnesses.Maybe
+import Darcs.Patch.Witnesses.Ordered
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 44
+instance PropagateShrink prim p => PropagateShrink prim (Named p) where
+ propagateShrink (prim :> NamedP pi deps ps) = do
+ mps' :> mprim' <- propagateShrink (prim :> ps)
+ return (mapMB_MB (NamedP pi deps) mps' :> mprim')
+
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 9
- -import Darcs.Patch.Prim.WithName ( wnPatch )
+import Darcs.Patch.Prim.WithName ( PrimWithName(..), wnPatch )
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 17
+import Darcs.Patch.Witnesses.Maybe
+import Darcs.Patch.Witnesses.Ordered
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 38
+instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (PrimWithName n2 prim2) where
+ propagateShrink (p1 :> PrimWithName n2 p2) = do
+ mp2' :> mp1' <- propagateShrink (p1 :> p2)
+ return (mapMB_MB (PrimWithName n2) mp2' :> mp1')
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 43
+instance PropagateShrink Prim Prim where
+ propagateShrink = propagatePrim
+
+instance ShrinkModel FileUUIDModel Prim where
+ -- no shrinking for now
+ shrinkModelPatch _ = []
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 186
+aModelShrink :: V1Model wX -> [Sealed (Prim.Prim wX)]
+aModelShrink _repo = []
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 327
+instance ShrinkModel V1Model Prim.Prim where
+ shrinkModelPatch s = aModelShrink s
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 333
+instance ShrinkModel V1Model Prim1 where
+ shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s
+
+instance PropagateShrink Prim1 Prim1 where
+ propagateShrink = propagatePrim
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 342
- -
+instance ShrinkModel V1Model Prim2 where
+ shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s
+
+instance PropagateShrink Prim2 Prim2 where
+ propagateShrink = propagatePrim
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 22
+import Darcs.Patch.Witnesses.Show
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 35
+ , Show2 p
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 18
- -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 31
- -import Darcs.Patch ( addfile, adddir, move,
- - hunk, tokreplace, binary,
- - changepref, invert, merge )
+import Darcs.Patch
+ ( addfile, adddir, move
+ , hunk, tokreplace, binary
+ , changepref, invert, merge
+ , commute
+ )
+import Darcs.Patch.Prim ( PrimPatch )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 42
+import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 55
+import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 128
+instance
+ ( PrimPatch prim, PropagateShrink prim prim
+ )
+ => PropagateShrink prim (RepoPatchV1 prim) where
+ propagateShrink (prim1 :> PP prim2) = do
+ mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
+ return $ mapMB_MB PP mprim2' :> mprim1'
+ -- Actually shrinking conflicts is hard to do correctly,
+ -- because the correctness of the conflict depends on the
+ -- patch the conflict is with which isn't visible here,
+ -- but we can try to commute past them.
+ propagateShrink (prim1 :> p2) = do
+ p2' :> PP prim1' <- commute (PP prim1 :> p2)
+ return $ Just2 p2' :> Just2 prim1'
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 1
+{-# LANGUAGE MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 4
+import Darcs.Prelude
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 9
+import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
+import Darcs.Patch.Commute ( commute )
+import Darcs.Patch.Prim.Class ( PrimPatch )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 13
- -import Darcs.Patch.V2.RepoPatch ( isDuplicate )
+import Darcs.Patch.V2.RepoPatch ( isDuplicate, RepoPatchV2(Normal) )
+import Darcs.Patch.Witnesses.Maybe
+import Darcs.Patch.Witnesses.Ordered
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 26
+
+instance (PrimPatch prim, PropagateShrink prim prim)
+ => PropagateShrink prim (RepoPatchV2 prim) where
+
+ propagateShrink (prim1 :> Normal prim2) = do
+ mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
+ return $ mapMB_MB Normal mprim2' :> mprim1'
+ -- Actually shrinking conflicts is hard to do correctly,
+ -- because the correctness of the conflict depends on the
+ -- patch the conflict is with which isn't visible here,
+ -- but we can try to commute past them.
+ propagateShrink (prim1 :> p2) = do
+ p2' :> Normal prim1' <- commute (Normal prim1 :> p2)
+ return $ Just2 p2' :> Just2 prim1'
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 1
- -{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 8
+import Darcs.Test.Patch.Arbitrary.NamedPrim ()
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 11
+import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 13
+import qualified Darcs.Patch.V3.Core as V3 ( RepoPatchV3(Prim) )
+
+import Darcs.Patch.Witnesses.Maybe
+import Darcs.Patch.Witnesses.Ordered
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 27
+
+instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (RepoPatchV3 prim2) where
+ propagateShrink (prim1 :> V3.Prim prim2) = do
+ mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
+ return $ mapMB_MB V3.Prim mprim2' :> mprim1'
+ -- don't try to shrink conflicts, it's too hard to do correctly
+ -- the general strategy for test cases is to define them with unconflicted patches
+ -- then use merge to generate conflicts
+ propagateShrink _ = Nothing
+
hunk ./harness/Darcs/Test/Patch/WithState.hs 9
+import Darcs.Patch.Apply
+import Darcs.Patch.Commute
+import Darcs.Patch.Effect
+import Darcs.Patch.FromPrim
+import Darcs.Patch.Invert
+import Darcs.Patch.Prim.Class
+import Darcs.Patch.Witnesses.Eq
+import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/WithState.hs 20
- -import Test.QuickCheck ( Gen, sized, choose )
+import Test.QuickCheck ( Gen, Arbitrary(..), sized, choose )
hunk ./harness/Darcs/Test/Patch/WithState.hs 23
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch/WithState.hs 25
+import Data.Maybe
+
hunk ./harness/Darcs/Test/Patch/WithState.hs 61
+-- |'WithStartState2' is like 'WithStartState' but for patches that have both witnesses.
+-- TODO: Possibly @WithStartState (Sealed p)@ could be replaced with @Sealed (WithStartState2 p)@.
+data WithStartState2 s p wX wY =
+ WithStartState2
+ { wss2StartState :: s wX
+ , wss2Patch :: p wX wY
+ }
+ deriving Eq
+
+instance (Show1 s, Show2 p) => Show (WithStartState2 s p wX wY) where
+ showsPrec d (WithStartState2 s p) =
+ showParen (d > appPrec) $ showString "WithStartState2 " .
+ showsPrec1 (appPrec + 1) s . showString " " .
+ showsPrec2 (appPrec + 1) p
+
+instance (Show1 s, Show2 p) => Show1 (WithStartState2 s p wX)
+instance (Show1 s, Show2 p) => Show2 (WithStartState2 s p)
+
+
hunk ./harness/Darcs/Test/Patch/WithState.hs 166
+class ShrinkModel s prim where
+ shrinkModelPatch :: s wX -> [Sealed (prim wX)]
+
+checkOK :: Fail a -> [a]
+checkOK (OK a) = [a]
+checkOK (Failed _) = []
+
+shrinkModel
+ :: forall s prim wX
+ . (Apply prim, ApplyState prim ~ RepoState s, RepoModel s, ShrinkModel s prim)
+ => s wX -> [Sealed (WithEndState s (prim wX))]
+shrinkModel s = do
+ Sealed prim <- shrinkModelPatch s
+ endState <- checkOK $ repoApply s prim
+ return $ Sealed $ WithEndState prim endState
+
+-- | A class to help with shrinking complex test cases. The idea is that the
+-- "starting state" of the test case is shrunk and this results in a "fixup"
+-- primitive that goes from the shrunk starting state to the original starting
+-- state. This so-called "shrinking fixup" is then propagated through the test
+-- case to generate a new test case that starts at the shrunk starting state.
+class PropagateShrink prim p where
+ -- Given a test patch (of type @p@) and a shrinking fixup (of type @prim@),
+ -- try to propagate the shrinking fixup past the test patch.
+ -- The @Maybe2 p@ return type allows the fixup to eliminate the shrinking
+ -- patch entirely, and vice versa the @Maybe2 prim@ allows the shrinking fixup
+ -- to disappear (for example it might be cancelled out by something in the test
+ -- patch).
+ -- We don't use @FL p@, because that would only really be useful for a "stuck"
+ -- fixup - one that doesn't eliminate or commute - and that implies that
+ -- the state shrink isn't actually shrinking the real test case.
+ propagateShrink :: (prim :> p) wX wY -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)
+
+propagateShrinkKeep
+ :: PropagateShrink prim p
+ => (prim :> p) wX wY
+ -> Maybe ((p :> Maybe2 prim) wX wY)
+propagateShrinkKeep inp = do
+ Just2 p' :> mprim' <- propagateShrink inp
+ return (p' :> mprim')
+
+propagateShrinkMaybe
+ :: PropagateShrink prim p
+ => (Maybe2 prim :> p) wX wY
+ -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)
+propagateShrinkMaybe (Nothing2 :> p) = Just (Just2 p :> Nothing2)
+propagateShrinkMaybe (Just2 prim :> p) = propagateShrink (prim :> p)
+
+shrinkState
+ :: forall s prim p
+ . ( Invert prim, Apply prim, RepoModel s
+ , ShrinkModel s prim, PropagateShrink prim p
+ , ApplyState prim ~ RepoState s
+ )
+ => Sealed2 (WithStartState2 s p)
+ -> [Sealed2 (WithStartState2 s p)]
+shrinkState (Sealed2 (WithStartState2 s p)) = do
+ Sealed (WithEndState fixup shrunkState) <- shrinkModel @s @prim s
+ p' :> _ <- maybeToList $ propagateShrinkKeep (invert fixup :> p)
+ return $ Sealed2 $ WithStartState2 shrunkState p'
+
+shrinkAtStartState
+ :: ( Shrinkable p, RepoModel s, Effect p
+ , prim ~ PrimOf p, Invert prim, Apply prim
+ , ApplyState prim ~ RepoState s
+ )
+ => WithStartState2 s p wX wY
+ -> [FlippedSeal (WithStartState2 s p) wY]
+shrinkAtStartState (WithStartState2 s p) = do
+ FlippedSeal p' <- shrinkAtStart p
+ endState <- checkOK $ repoApply s (effect p)
+ newState <- checkOK $ repoApply endState (invert (effect p'))
+ return $ FlippedSeal (WithStartState2 newState p')
+
+instance
+ ( ArbitraryState s p, Shrinkable p, RepoModel s
+ , s ~ ModelOf p
+ , Effect p
+ , Apply prim, ApplyState prim ~ RepoState s
+ , prim ~ PrimOf p, Invert prim, ShrinkModel s prim, PropagateShrink prim p
+ )
+ => Arbitrary (Sealed2 (WithStartState2 s p)) where
+ arbitrary = do
+ repo <- aSmallRepo @s
+ Sealed (WithEndState p _) <- arbitraryState repo
+ return (Sealed2 (WithStartState2 repo p))
+ shrink w@(Sealed2 (WithStartState2 repo p)) =
+ map (Sealed2 . WithStartState2 repo) (shrinkInternally p) ++
+ map (unseal (Sealed2 . WithStartState2 repo)) (shrinkAtEnd p) ++
+ map (unsealFlipped Sealed2) (shrinkAtStartState (WithStartState2 repo p)) ++
+ shrinkState @s @prim @p w
+
+withStateShrinking :: (forall wX wY. p wX wY -> r) -> Sealed2 (WithStartState2 (ModelOf p) p) -> r
+withStateShrinking prop (Sealed2 (WithStartState2 _ p)) = prop p
+
+propagatePrim
+ :: (Eq2 prim, PrimCanonize prim, Invert prim, Commute prim)
+ => (prim :> prim) wX wY -> Maybe ((Maybe2 prim :> Maybe2 prim) wX wY)
+propagatePrim (p1 :> p2)
+ | IsEq <- invert p1 =\/= p2 = Just (Nothing2 :> Nothing2)
+ | Just (p2' :> p1') <- commute (p1 :> p2) = Just (Just2 p2' :> Just2 p1')
+ | Just p' <- primCoalesce p1 p2 = Just (Just2 p' :> Nothing2)
+ | otherwise = Nothing
+
+instance (PropagateShrink prim p, PropagateShrink prim q)
+ => PropagateShrink prim (p :> q) where
+
+ propagateShrink (prim :> (p :> q)) = do
+ Just2 mp' :> mprim' <- propagateShrink (prim :> p)
+ Just2 mq' :> mprim'' <- propagateShrinkMaybe (mprim' :> q)
+ return (Just2 (mp' :> mq') :> mprim'')
+
+instance PropagateShrink prim p => PropagateShrink prim (FL p) where
+ propagateShrink (prim :> NilFL) = Just (Just2 NilFL :> Just2 prim)
+ propagateShrink (prim :> (p :>: ps)) = do
+ mp' :> mprim' <- propagateShrink (prim :> p)
+ Just2 ps' :> mprim'' <- propagateShrinkMaybe (mprim' :> ps)
+ let result = case mp' of
+ Nothing2 -> ps'
+ Just2 p' -> p' :>: ps'
+ return (Just2 result :> mprim'')
+
[shrinking names and file content
Ganesh Sittampalam <ganesh at earth.li>**20200209002238
Ignore-this: 61be1064b90b1d3ae906e6aba3a08601
] hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 19
+import Control.Applicative ( (<|>) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 41
+import Control.Monad ( guard )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 189
- -aModelShrink _repo = []
+aModelShrink repo =
+ aModelShrinkName repo <|>
+ aModelDeleteFile repo <|>
+ aModelDeleteDir repo <|>
+ aModelShrinkFileContent repo
+
+shrinkPath :: AnchoredPath -> [AnchoredPath]
+shrinkPath (AnchoredPath ps) = do
+ ps' <- shrinkList shrinkName ps
+ guard (not $ null ps')
+ return $ AnchoredPath ps'
+
+shrinkName :: Name -> [Name]
+shrinkName n = do
+ n' <- shrink (BC.unpack . encodeWhiteName $ n)
+ guard (n' /= ".")
+ guard (not $ null n')
+ return $ decodeWhiteName $ BC.pack n'
+
+aModelShrinkName :: V1Model wX -> [Sealed (Prim.Prim wX)]
+aModelShrinkName repo = do
+ (oldPath, _) <- list repo
+ newPath <- shrinkPath oldPath
+ return $ Sealed $ move oldPath newPath
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 214
+aModelDeleteFile :: V1Model wX -> [Sealed (Prim.Prim wX)]
+aModelDeleteFile repo = do
+ (path, _) <- filterFiles (list repo)
+ return $ Sealed $ rmfile path
+
+aModelDeleteDir :: V1Model wX -> [Sealed (Prim.Prim wX)]
+aModelDeleteDir repo = do
+ (path, _) <- filterDirs (list repo)
+ return $ Sealed $ rmdir path
+
+aModelShrinkFileContent :: V1Model wX -> [Sealed (Prim.Prim wX)]
+aModelShrinkFileContent repo = do
+ (path, file) <- filterFiles (list repo)
+ (pos, lineToRemove) <- zip [0..] $ fileContent file
+ (return (Sealed $ hunk path pos [lineToRemove] [])
+ <|>
+ do
+ smaller <- BC.pack <$> shrink (BC.unpack lineToRemove)
+ return $ Sealed $ hunk path pos [lineToRemove] [smaller])
+
+
[tests: introduce an explicit MergeableSequence type
Ganesh Sittampalam <ganesh at earth.li>**20200209193131
Ignore-this: e66e93547c9fb1afa63680b745289f52
] hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 32
+ , MergeableSequence(..)
+ , arbitraryMergeableSequence
+ , mergeableSequenceToRL
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 39
+import Control.Applicative ( (<|>) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 43
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 366
+-- | A witness type that makes the result witness of merging explicit:
+--
+-- wB ----> Merged wA wB
+-- ^ ^
+-- | |
+-- | |
+-- wBase ----> wA
+--
+-- It's quite ad hoc, for example we don't define a type for 'wBase'.
+data Merged wA wB
+
+typedMerge
+ :: Merge p
+ => (p :\/: p) wA wB
+ -> (p wA (Merged wA wB), p wB (Merged wA wB))
+typedMerge (p :\/: q) =
+ case merge (p :\/: q) of
+ (q' :/\: p') -> (unsafeCoercePEnd q', unsafeCoercePEnd p')
+
+-- | This type provides a concrete, pre-merged representation of a sequence
+-- of patches that might have conflicts once merged. The structure also allows
+-- for conflict resolutions, e.g. in @SeqMS (ParMS x y) z@, @z@ could be a
+-- resolution patch.
+-- Working with the pre-merged patches makes it easier to manipulate the test
+-- case, e.g. for shrinking.
+data MergeableSequence p wX wY where
+ NilMS :: MergeableSequence p wX wX
+ SeqMS
+ :: MergeableSequence p wX wY
+ -> p wY wZ
+ -> MergeableSequence p wX wZ
+ ParMS
+ :: MergeableSequence p wX wA
+ -> MergeableSequence p wX wB
+ -> MergeableSequence p wX (Merged wA wB)
+
+instance Show2 p => Show (MergeableSequence p wX wY) where
+ showsPrec _d NilMS = showString "NilMS"
+ showsPrec d (SeqMS ms p) =
+ showParen (d > appPrec) $ showString "SeqMS " . showsPrec2 (appPrec + 1) ms . showString " " . showsPrec2 (appPrec + 1) p
+ showsPrec d (ParMS ms1 ms2) =
+ showParen (d > appPrec) $ showString "ParMS " . showsPrec2 (appPrec + 1) ms1 . showString " " . showsPrec2 (appPrec + 1) ms2
+
+instance Show2 p => Show1 (MergeableSequence p wX)
+instance Show2 p => Show2 (MergeableSequence p)
+
+type instance ModelOf (MergeableSequence p) = ModelOf p
+
+parMS
+ :: MergeableSequence p wX wA
+ -> MergeableSequence p wX wB
+ -> MergeableSequence p wX (Merged wA wB)
+parMS NilMS ms = unsafeCoercePEnd ms
+parMS ms NilMS = unsafeCoercePEnd ms
+parMS ms1 ms2 = ParMS ms1 ms2
+
+instance Shrinkable p => Shrinkable (MergeableSequence p) where
+ shrinkInternally NilMS = []
+ shrinkInternally (SeqMS ms p) =
+ SeqMS ms <$> shrinkInternally p
+ <|>
+ flip SeqMS p <$> shrinkInternally ms
+ shrinkInternally (ParMS ms1 ms2) =
+ parMS ms1 <$> shrinkInternally ms2
+ <|>
+ flip parMS ms2 <$> shrinkInternally ms1
+
+ shrinkAtStart NilMS = []
+ shrinkAtStart (SeqMS NilMS p) = mapFlipped (SeqMS NilMS) <$> shrinkAtStart p
+ shrinkAtStart (ParMS {}) = []
+ shrinkAtStart (SeqMS (ParMS {}) p) = [FlippedSeal (SeqMS NilMS p)]
+ shrinkAtStart (SeqMS ms p) = mapFlipped (flip SeqMS p) <$> shrinkAtStart ms
+
+ shrinkAtEnd NilMS = []
+ shrinkAtEnd (SeqMS ms p) =
+ Sealed ms:map (mapSeal (SeqMS ms)) (shrinkAtEnd p)
+ shrinkAtEnd (ParMS ms1 ms2) =
+ do
+ Sealed ms2' <- shrinkAtEnd ms2
+ return $ Sealed $ parMS ms1 ms2'
+ <|>
+ do
+ Sealed ms1' <- shrinkAtEnd ms1
+ return $ Sealed $ parMS ms1' ms2
+
+mergeableSequenceToRL
+ :: Merge p
+ => MergeableSequence p wX wY
+ -> RL p wX wY
+mergeableSequenceToRL NilMS = NilRL
+mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: p
+mergeableSequenceToRL (ParMS ms1 ms2) =
+ let
+ ps1 = mergeableSequenceToRL ms1
+ ps2 = mergeableSequenceToRL ms2
+ in
+ case typedMerge (reverseRL ps1 :\/: reverseRL ps2) of
+ (ps2', _) -> ps1 +<<+ ps2'
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 469
- -arbitraryMergedSequence
+arbitraryMergeableSequence
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 477
- - -> Gen (Sealed (WithEndState model (RL p wX)))
- -arbitraryMergedSequence arbitrarySingle = go
+ -> Gen (Sealed (WithEndState model (MergeableSequence p wX)))
+arbitraryMergeableSequence arbitrarySingle = go
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 481
- - | depth == 0 = return $ Sealed $ WithEndState NilRL rm
+ | depth == 0 = return $ Sealed $ WithEndState NilMS rm
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 485
- - , do Sealed (WithEndState ps rm') <- go rm (depth - 1)
+ , do Sealed (WithEndState ms rm') <- go rm (depth - 1)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 487
- - return $ Sealed $ WithEndState (ps :<: p) rm'')
+ return $ Sealed $ WithEndState (SeqMS ms p) rm'')
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 489
- - , do Sealed (WithEndState ps1 _) <- go rm ((depth + 1) `div` 2)
- - Sealed (WithEndState ps2 _) <- go rm (depth `div` 2)
- - case merge (reverseRL ps1 :\/:reverseRL ps2) of
- - ps2' :/\: _ ->
+ , do Sealed (WithEndState ms1 _) <- go rm ((depth + 1) `div` 2)
+ Sealed (WithEndState ms2 _) <- go rm (depth `div` 2)
+ let ps1 = mergeableSequenceToRL ms1
+ ps2 = mergeableSequenceToRL ms2
+ case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of
+ (ps2', _) ->
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 497
- - WithEndState (ps1 +<<+ ps2') rm'
+ WithEndState (parMS ms1 ms2) rm'
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 502
+instance
+ ( RepoModel model
+ , Apply p, ApplyState p ~ RepoState model
+ , Commute p, Merge p
+ , ArbitraryState model p
+ )
+ => ArbitraryState model (MergeableSequence p) where
+ arbitraryState rm = bSized 3 0.035 9 $ arbitraryMergeableSequence arbitraryState rm
+
+-- | Generate an arbitrary sequence of patches, using a generator
+-- for the underlying patch type and merging.
+-- The sequence uses a given start state and is bounded by a
+-- given depth.
+arbitraryMergedSequence
+ :: ( RepoModel model
+ , Merge p
+ , Apply p, ApplyState p ~ RepoState model
+ )
+ => (forall wA . model wA -> Gen (Sealed (WithEndState model (p wA))))
+ -> model wX
+ -> Int
+ -> Gen (Sealed (WithEndState model (RL p wX)))
+arbitraryMergedSequence arbitrarySingle rm depth = do
+ Sealed (WithEndState ms rm') <- arbitraryMergeableSequence arbitrarySingle rm depth
+ return (Sealed (WithEndState (mergeableSequenceToRL ms) rm'))
+
[tests: add PropagateShrink and Effect for MergeableSequence
Ganesh Sittampalam <ganesh at earth.li>**20200209195224
Ignore-this: 1b4750b31b984dacfea9b3ef62cf6093
] hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 47
+import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 53
+import Darcs.Patch.Effect ( Effect(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 58
- -import Darcs.Patch.FromPrim ( FromPrim(..), PrimOf )
+import Darcs.Patch.FromPrim ( FromPrim(..), PrimPatchBase, PrimOf )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 404
+instance PrimPatchBase p => PrimPatchBase (MergeableSequence p) where
+ type PrimOf (MergeableSequence p) = PrimOf p
+
+instance (Merge p, Effect p) => Effect (MergeableSequence p) where
+ effect NilMS = NilFL
+ effect (SeqMS ps p) = effect ps +>+ effect p
+ effect (ParMS ms1 ms2) =
+ let ps1 = mergeableSequenceToRL ms1
+ ps2 = mergeableSequenceToRL ms2
+ in case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of
+ (ps2', _) -> effect ms1 +>+ effect ps2'
+
+
+instance PropagateShrink prim p => PropagateShrink prim (MergeableSequence p) where
+ -- Note that the result of propagateShrink is always either
+ -- Just (Just2 _ :> _) or Nothing, so we don't need to worry about
+ -- the Just (Nothing2 :> _) case in recursive calls.
+ propagateShrink (prim :> NilMS) = Just (Just2 NilMS :> Just2 prim)
+ propagateShrink (prim :> SeqMS ps p) = do
+ Just2 ps' :> mprim' <- propagateShrink (prim :> ps)
+ mp' :> mprim'' <- propagateShrinkMaybe (mprim' :> p)
+ let result = case mp' of
+ Just2 p' -> SeqMS ps' p'
+ Nothing2 -> ps'
+ return (Just2 result :> mprim'')
+ propagateShrink (prim :> ParMS ps1 ps2) = do
+ -- we insist the prim disappears in both branches as
+ -- otherwise we have a complicated merge to figure out
+ Just2 ps1' :> Nothing2 <- propagateShrink (prim :> ps1)
+ Just2 ps2' :> Nothing2 <- propagateShrink (prim :> ps2)
+ return (Just2 (parMS ps1' ps2') :> Nothing2)
+
[tests: better shrinking for MergeableSequence.ParMS
Ganesh Sittampalam <ganesh at earth.li>**20200209223923
Ignore-this: f4da4cb50b7cac3372b4a89a6ae22ae6
] hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 59
- -import Darcs.Patch.Prim ( PrimCanonize )
+import Darcs.Patch.Prim ( sortCoalesceFL, PrimCanonize )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 417
- -instance PropagateShrink prim p => PropagateShrink prim (MergeableSequence p) where
+instance
+ ( PropagateShrink prim p
+ , Merge p, Effect p, PrimOf p ~ prim
+ , Invert prim, PrimCanonize prim
+ )
+ => PropagateShrink prim (MergeableSequence p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 434
- - propagateShrink (prim :> ParMS ps1 ps2) = do
- - -- we insist the prim disappears in both branches as
- - -- otherwise we have a complicated merge to figure out
- - Just2 ps1' :> Nothing2 <- propagateShrink (prim :> ps1)
- - Just2 ps2' :> Nothing2 <- propagateShrink (prim :> ps2)
- - return (Just2 (parMS ps1' ps2') :> Nothing2)
+ propagateShrink
+ ((prim :: prim wA wB) :>
+ ParMS (ms1 :: MergeableSequence p wB wD1) (ms2 :: MergeableSequence p wB wD2)) = do
+ Just2 (ms1' :: MergeableSequence p wA wC1) :> (mprim1' :: Maybe2 prim wC1 wD1)
+ <- propagateShrink (prim :> ms1)
+ Just2 (ms2' :: MergeableSequence p wA wC2) :> (mprim2' :: Maybe2 prim wC2 wD2)
+ <- propagateShrink (prim :> ms2)
+ let
+ ms' :: MergeableSequence p wA (Merged wC1 wC2)
+ ms' = parMS ms1' ms2'
+ ps1 :: FL p wB wD1
+ ps2 :: FL p wB wD2
+ mergedps1 :: FL p wD2 (Merged wD1 wD2)
+ mergedps2 :: FL p wD1 (Merged wD1 wD2)
+ ps1' :: FL p wA wC1
+ ps2' :: FL p wA wC2
+ mergedps1' :: FL p wC2 (Merged wC1 wC2)
+ mergedps2' :: FL p wC1 (Merged wC1 wC2)
+ ps1 = reverseRL (mergeableSequenceToRL ms1)
+ ps2 = reverseRL (mergeableSequenceToRL ms2)
+ ps1' = reverseRL (mergeableSequenceToRL ms1')
+ ps2' = reverseRL (mergeableSequenceToRL ms2')
+ (mergedps2 , mergedps1 ) = typedMerge (ps1 :\/: ps2 )
+ (mergedps2', mergedps1') = typedMerge (ps1' :\/: ps2')
+ -- Unless the shrinking prim disappears on both branches of the merge,
+ -- we'll need to try to recalculate it for the result of the merge - trying
+ -- to use propagateShrink a second time wouldn't guarantee the right
+ -- contexts. (This is a bit complicated to see, hence all the type signatures
+ -- in this function.)
+ recalcShrink
+ :: prim wX wY
+ -> FL p wY (Merged wD1 wD2)
+ -> FL p wX (Merged wC1 wC2)
+ -> Maybe (Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2))
+ recalcShrink primIn m1 m2 =
+ case sortCoalesceFL (invert (effect m2) +>+ primIn :>: effect m1) of
+ NilFL -> Just Nothing2
+ prim' :>: NilFL -> Just (Just2 prim')
+ -- If we don't get 0 or 1 prims, we can't use this result given the type
+ -- of propagateShrink as a whole. If that was changed to return an FL we
+ -- could use it, but at the cost of more complexity elsewhere.
+ _ -> Nothing
+ mprim' :: Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2)
+ <-
+ case (mprim1', mprim2') of
+ (Nothing2, Nothing2) -> Just Nothing2
+ (Just2 prim1', _) | Just prim'' <- recalcShrink prim1' mergedps2 mergedps2' -> Just prim''
+ (_, Just2 prim2') | Just prim'' <- recalcShrink prim2' mergedps1 mergedps1' -> Just prim''
+ _ -> Nothing
+ return (Just2 ms' :> mprim')
[tests: add some more comments about ShrinkModel/PropagateShrink
Ganesh Sittampalam <ganesh at earth.li>**20200212130152
Ignore-this: 4268562c02d9b5409c1c0dbf1bfa9ce1
] hunk ./harness/Darcs/Test/Patch/WithState.hs 165
- -
+-- | A class to help with shrinking complex test cases by simplifying
+-- the starting state of the test case. See also 'PropagateShrink'.
hunk ./harness/Darcs/Test/Patch/WithState.hs 168
+ -- |Given a repository state, produce a patch that simplifies the
+ -- repository state. The inverse of the patch can be passed as the
+ -- "shrinking fixup" to 'propagateShrink'.
+ --
+ -- Imagine that we start with
+ --
+ -- s wX1 --p1 wX1 wY1--> s wY1
+ --
+ -- If we shrink the state to @s wX2@:
+ --
+ -- s wX2 <--prim wX1 wX2-- s wX1
+ --
+ -- then we hope that 'propagateShrink' will produce a simpler version of @p1@,
+ -- @p2@, that starts from the simpler state @s wX2@:
+ --
+ -- p2 wX2 wY2
+ -- s wX2 ----------------> s wY2
+ -- | |
+ -- | |
+ -- invert prim | | (discard)
+ -- | |
+ -- V V
+ -- s wX1 ----------------> s wY1
+ -- p1 wX1 wY1
hunk ./harness/Darcs/Test/Patch/WithState.hs 212
+-- The shrinking fixup is typically generated via the 'ShrinkModel' class.
hunk ./harness/Darcs/Test/Patch/WithState.hs 240
+-- |Shrink a test case wrapped with 'WithStartState2' by shrinking the start state
+-- of the test case with 'ShrinkModel' and then propagating the shrink through the
+-- patch type of the test case.
hunk ./harness/Darcs/Test/Patch/WithState.hs 287
+-- |Given a property on patches, wrap it with 'WithStartState2' so that we get shrinking of
+-- any counter-examples, including simplification of the underlying repository via
+-- 'ShrinkModel'/'PropagateShrink'.
[tests: remove invalid TODO
Ganesh Sittampalam <ganesh at earth.li>**20200215142125
Ignore-this: ea4ae459b88fd2263b69932461228e4e
many of the uses of WithStartState are with single-parameter patches
like Tree so can't be easily replaced by WithStartState2.
] hunk ./harness/Darcs/Test/Patch/WithState.hs 62
- --- TODO: Possibly @WithStartState (Sealed p)@ could be replaced with @Sealed (WithStartState2 p)@.
[tests: sort default-extensions
Ganesh Sittampalam <ganesh at earth.li>**20200215143632
Ignore-this: 5799beffc4b5909536a0bdbd12e9e631
] hunk ./darcs.cabal 623
- - NoImplicitPrelude
- - GADTSyntax
+ AllowAmbiguousTypes
+ ConstraintKinds
+ DataKinds
hunk ./darcs.cabal 627
- - TypeOperators
hunk ./darcs.cabal 629
- - ScopedTypeVariables
- - RoleAnnotations
+ GADTSyntax
hunk ./darcs.cabal 631
- - DataKinds
- - ConstraintKinds
- - RankNTypes
- - TypeFamilies
+ NoImplicitPrelude
hunk ./darcs.cabal 633
- - AllowAmbiguousTypes
- - TypeApplications
+ RankNTypes
+ RoleAnnotations
+ ScopedTypeVariables
hunk ./darcs.cabal 637
+ TypeApplications
+ TypeFamilies
+ TypeOperators
[tests: add DefaultSignatures to .cabal file
Ganesh Sittampalam <ganesh at earth.li>**20200215144040
Ignore-this: dec50e31599f57cc287b58602832fe13
] hunk ./darcs.cabal 626
+ DefaultSignatures
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 2
- - FlexibleInstances, ViewPatterns, DefaultSignatures #-}
+ FlexibleInstances, ViewPatterns #-}
[tests: remove some redundant LANGUAGE pragmas
Ganesh Sittampalam <ganesh at earth.li>**20200215145542
Ignore-this: d52d2fac5ff315db7ae7299826ab8e2b
] hunk ./harness/Darcs/Test/HashedStorage.hs 1
- -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
hunk ./harness/Darcs/Test/Patch.hs 1
- -{-# LANGUAGE AllowAmbiguousTypes, PolyKinds #-}
+{-# LANGUAGE PolyKinds #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 1
- -{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,
- - FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, ViewPatterns #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 1
- -{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,
- - FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, ViewPatterns #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 18
- -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/FileUUIDModel.hs 1
- -{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}
+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/Properties/Check.hs 1
- -{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
hunk ./harness/Darcs/Test/Patch/WithState.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
[tests: list MultiParamTypeClasses in the cabal file
Ganesh Sittampalam <ganesh at earth.li>**20200215145635
Ignore-this: d8b663f4afce28f361693cbb74f3e01
It's very widely used in the tests and generally we wouldn't
think twice about using it in test code/infrastructure.
] hunk ./darcs.cabal 632
+ MultiParamTypeClasses
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 1
- -{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances, ViewPatterns #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings, UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 1
- -{-# LANGUAGE MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 1
- -{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, ViewPatterns #-}
+{-# LANGUAGE MultiParamTypeClasses, ViewPatterns #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 18
- -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 1
- -{-# LANGUAGE MultiParamTypeClasses #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/FileUUIDModel.hs 1
- -{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
hunk ./harness/Darcs/Test/Patch/WSub.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}
hunk ./harness/Darcs/Test/TestOnly/Instance.hs 1
- -{-# LANGUAGE MultiParamTypeClasses #-}
[tests: remove unnecessary UndecidableInstances
Ganesh Sittampalam <ganesh at earth.li>**20200215151804
Ignore-this: 9fd444532408dfd226224de97e130b5c
] hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 1
- -{-# LANGUAGE UndecidableInstances #-}
[tests: NoMonoLocalBinds needs to come last
Ganesh Sittampalam <ganesh at earth.li>**20200215171259
Ignore-this: d64359aa16094e9661bf99f127466880
] hunk ./darcs.cabal 634
- - NoMonoLocalBinds
hunk ./darcs.cabal 641
+ -- this must come last because some of the
+ -- other extensions imply MonoLocalBinds
+ NoMonoLocalBinds
[tests: correct mistake in MultiParamTypeClasses patch
Ganesh Sittampalam <ganesh at earth.li>**20200215165649
Ignore-this: a4d22f3ce42119e12920d91338445da2
I accidentally removed UndecidableInstances when resolving a
local conflict.
] hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances, ViewPatterns #-}
[specialise the types of withSingle etc
Ganesh Sittampalam <ganesh at earth.li>**20200214065131
Ignore-this: 3fda114ae11a17b6d24fd8e86b4a00ee
The new types reflect their actual usage and will make it
easier to move logic around.
] hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 73
- -withPair :: (forall wX wY. p wX wY -> r) -> Pair (Sealed2 p) -> r
+withPair :: (forall wX wY. (p :> p) wX wY -> r) -> Pair (Sealed2 (p :> p)) -> r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 76
- -withTriple :: (forall wX wY. p wX wY -> r) -> Triple (Sealed2 p) -> r
+withTriple :: (forall wX wY. (p :> p :> p) wX wY -> r) -> Triple (Sealed2 (p :> p :> p)) -> r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 79
- -withFork :: (forall wX wY. p wX wY -> r) -> Fork (Sealed2 p) -> r
+withFork :: (forall wX wY. (FL p :\/: FL p) wX wY -> r) -> Fork (Sealed2 (FL p :\/: FL p)) -> r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 82
- -withSequence :: (forall wX wY. p wX wY -> r) -> Sequence (Sealed2 p) -> r
+withSequence :: (forall wX wY. RL p wX wY -> r) -> Sequence (Sealed2 (RL p)) -> r
[use the shrinking for MergeableSequence on existing tests
Ganesh Sittampalam <ganesh at earth.li>**20200215092921
Ignore-this: e98eb2288d356604409adcf005701f40
] hunk ./harness/Darcs/Test/Patch.hs 67
- - ( WithState, WithStartState, WithStartModel
+ ( WithState, WithStartState
+ , ArbitraryState
hunk ./harness/Darcs/Test/Patch.hs 287
- -type SequenceWithModelProperty p = forall wA. WithStartModel (RL p) wA -> TestResult
hunk ./harness/Darcs/Test/Patch.hs 293
+ , ArbitraryState (ModelOf p) p
hunk ./harness/Darcs/Test/Patch.hs 321
+ , ArbitraryState (ModelOf p) p
+ , Shrinkable p
+ , ShrinkModel (ModelOf p) (PrimOf p)
+ , PropagateShrink (PrimOf p) p
hunk ./harness/Darcs/Test/Patch.hs 332
- - (PropR.propConsistentReorderings :: SequenceWithModelProperty p)
+ (PropR.propConsistentReorderings @p)
hunk ./harness/Darcs/Test/Patch.hs 343
- - (withPair nontrivialCommute)
+ (fromNothing . withPair nontrivialCommute)
hunk ./harness/Darcs/Test/Patch.hs 346
- - (withTriple notDuplicatestriple)
+ (fromNothing . withTriple notDuplicatestriple)
hunk ./harness/Darcs/Test/Patch.hs 349
- - (withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))
+ (fromNothing . withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))
hunk ./harness/Darcs/Test/Patch.hs 358
- - (withFork nontrivialMerge)
+ (fromNothing . withFork nontrivialMerge)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 30
- - , arbitraryMergedSequence
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 592
- --- | Generate an arbitrary sequence of patches, using a generator
- --- for the underlying patch type and merging.
- --- The sequence uses a given start state and is bounded by a
- --- given depth.
- -arbitraryMergedSequence
- - :: ( RepoModel model
- - , Merge p
- - , Apply p, ApplyState p ~ RepoState model
- - )
- - => (forall wA . model wA -> Gen (Sealed (WithEndState model (p wA))))
- - -> model wX
- - -> Int
- - -> Gen (Sealed (WithEndState model (RL p wX)))
- -arbitraryMergedSequence arbitrarySingle rm depth = do
- - Sealed (WithEndState ms rm') <- arbitraryMergeableSequence arbitrarySingle rm depth
- - return (Sealed (WithEndState (mergeableSequenceToRL ms) rm'))
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 8
- -import Darcs.Patch.Prim.Named ( NamedPrim, PrimPatchId, unsafePrimPatchId )
+import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim, PrimPatchId, unsafePrimPatchId )
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 19
+import Darcs.Patch.Witnesses.Sealed
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 39
+instance ArbitraryState model prim => ArbitraryState model (NamedPrim prim) where
+ arbitraryState repo = do
+ Sealed (WithEndState p repo') <- arbitraryState repo
+ pid <- aPatchId
+ return $ Sealed $ WithEndState (namedPrim pid p) repo'
+
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 7
- -import Control.Applicative ( (<$>) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 28
- -aPrim :: FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY)
- -aPrim repo = do
- - WithEndState p repo' <- FileUUID.aPrim repo
- - pid <- aPatchId
- - return $ WithEndState (namedPrim pid p) repo'
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 36
- -instance ArbitraryState FileUUIDModel Prim where
- - arbitraryState s = seal <$> aPrim s
- -
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 7
- -import Control.Applicative ( (<$>) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 28
- -aPrim :: V1Model wX -> Gen (WithEndState V1Model (Prim wX) wY)
- -aPrim repo = do
- - WithEndState p repo' <- V1.aPrim repo
- - pid <- aPatchId
- - return $ WithEndState (namedPrim pid p) repo'
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 36
- -instance ArbitraryState V1Model Prim where
- - arbitraryState s = seal <$> aPrim s
- -
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 14
- -import Test.QuickCheck
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 16
- -import Darcs.Test.Patch.Arbitrary.Generic ( ArbitraryPrim(..), arbitraryMergedSequence )
- -import Darcs.Test.Util.QuickCheck ( bSized )
+import Darcs.Test.Patch.Arbitrary.Generic
+ ( mergeableSequenceToRL, MergeableSequence(..), ArbitraryPrim(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 22
- -import Darcs.Patch.Commute ( Commute(..) )
- -import Darcs.Patch.FromPrim ( FromPrim(..), PrimOf )
- -import Darcs.Patch.Permutations ( headPermutationsRL )
+import Darcs.Patch.FromPrim ( PrimOf )
+import Darcs.Patch.Merge ( Merge )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 35
- --- | Generate an arbitrary sequence of patches, bounded by depth,
- --- from a start state.
- -arbitrarySequence :: ArbitraryRepoPatch p
- - => (ModelOf p) wX
- - -> Int
- - -> Gen (Sealed (WithEndState (ModelOf p) (RL p wX)))
- -arbitrarySequence =
- - arbitraryMergedSequence $ \rm -> do
- - Sealed (WithEndState prim rm') <- arbitraryState rm
- - return $ Sealed $ WithEndState (fromAnonymousPrim prim) rm'
- -
- --- | Generate a properly sized sequence of patches from a start state.
- -arbitrarySizedSequence :: ArbitraryRepoPatch p
- - => (ModelOf p) wX
- - -> Gen (Sealed (WithEndState (ModelOf p) (RL p wX)))
- -arbitrarySizedSequence = bSized 3 0.035 9 . arbitrarySequence
- -
- --- | Generate an arbitrary sized sequence of patches from an arbitrary start
- --- state, returning only the sequence and not the state.
- -arbitraryRL :: ArbitraryRepoPatch p => Gen (Sealed (RL p wX))
- -arbitraryRL = do
- - repo <- aSmallRepo
- - Sealed (WithEndState ps _) <- arbitrarySizedSequence repo
- - return (seal ps)
- -
- --- These newtypes are here to avoid overlapping instances for the
- --- 'Arbitrary' instances below.
- -newtype Single x = Single x deriving (Show)
- -newtype Pair x = Pair x deriving (Show)
- -newtype Triple x = Triple x deriving (Show)
- -newtype Fork x = Fork x deriving (Show)
- -newtype Sequence x = Sequence x deriving (Show)
- -
- -withSingle :: (forall wX wY. p wX wY -> r) -> Single (Sealed2 p) -> r
- -withSingle prop p = case p of Single (Sealed2 pp) -> prop pp
- -
- -withPair :: (forall wX wY. (p :> p) wX wY -> r) -> Pair (Sealed2 (p :> p)) -> r
- -withPair prop p = case p of Pair (Sealed2 pp) -> prop pp
- -
- -withTriple :: (forall wX wY. (p :> p :> p) wX wY -> r) -> Triple (Sealed2 (p :> p :> p)) -> r
- -withTriple prop p = case p of Triple (Sealed2 pp) -> prop pp
- -
- -withFork :: (forall wX wY. (FL p :\/: FL p) wX wY -> r) -> Fork (Sealed2 (FL p :\/: FL p)) -> r
- -withFork prop p = case p of Fork (Sealed2 pp) -> prop pp
- -
- -withSequence :: (forall wX wY. RL p wX wY -> r) -> Sequence (Sealed2 (RL p)) -> r
- -withSequence prop p = case p of Sequence (Sealed2 pp) -> prop pp
- -
- -instance ArbitraryRepoPatch p => Arbitrary (Single (Sealed2 p)) where
- - arbitrary = do
- - Sealed ps <- arbitraryRL `suchThat` (\(Sealed s) -> lengthRL s >= 1)
- - Single <$> elements (mapRL seal2 ps)
- -
- -instance ArbitraryRepoPatch p => Arbitrary (Pair (Sealed2 (p :> p))) where
- - arbitrary = do
- - Sealed ps <- arbitraryRL `suchThat` (\(Sealed s) -> lengthRL s >= 2)
- - Pair <$> elements (getPairsRL ps)
- -
- -instance ArbitraryRepoPatch p => Arbitrary (Triple (Sealed2 (p :> p :> p))) where
- - arbitrary = do
- - Sealed ps <- arbitraryRL `suchThat` (\(Sealed s) -> lengthRL s >= 3)
- - Triple <$> elements (getTriplesRL ps)
- -
- -instance ArbitraryRepoPatch p => Arbitrary (Fork (Sealed2 (FL p :\/: FL p))) where
- - arbitrary = Fork <$> do
- - repo <- aSmallRepo
- - Sealed (WithEndState s1 _) <- arbitrarySizedSequence repo
- - Sealed (WithEndState s2 _) <- arbitrarySizedSequence repo
- - return (Sealed2 (reverseRL s1 :\/: reverseRL s2))
- - shrink (Fork (Sealed2 (ps :\/: qs))) =
- - [ Fork (Sealed2 (reverseRL ps' :\/: reverseRL qs'))
- - | Sealed ps' <- shrinkRL (reverseFL ps)
- - , Sealed qs' <- shrinkRL (reverseFL qs)
- - ]
- -
- --- | Generate all subsequences that start with the same context,
- --- in increasing order of length.
- -shrinkRL :: Commute p => RL p wX wY -> [Sealed (RL p wX)]
- -shrinkRL NilRL = []
- -shrinkRL ps = Sealed NilRL : recursive ++ onesmaller where
- - onesmaller = [ Sealed ps' | ps' :<: _ <- headPermutationsRL ps ]
- - recursive = concatMap (unseal shrinkRL) onesmaller
- -
- -instance ArbitraryRepoPatch p => Arbitrary (Sequence (Sealed2 (RL p))) where
- - arbitrary = Sequence . unseal seal2 <$> arbitraryRL
- - shrink (Sequence (Sealed2 ps)) = map (unseal (Sequence . Sealed2)) (shrinkRL ps)
- -
- -instance ArbitraryRepoPatch p => Arbitrary (WithStartModel (RL p) wX) where
- - arbitrary = do
- - repo <- aSmallRepo
- - Sealed (WithEndState ps _) <- arbitrarySizedSequence repo
- - return $ WithStartModel repo (Sealed ps)
- - -- TODO shrink the model, too
- - shrink (WithStartModel repo (Sealed ps)) =
- - map (unseal (WithStartModel repo . Sealed)) (shrinkRL ps)
- -
- -getPairsRL :: RL p wX wY -> [Sealed2 (p :> p)]
- -getPairsRL NilRL = []
- -getPairsRL (NilRL:<:_) = []
- -getPairsRL (a:<:b:<:c) = seal2 (b:>c) : getPairsRL (a:<:b)
- -
- -getTriplesRL :: RL p wX wY -> [Sealed2 (p :> p :> p)]
- -getTriplesRL NilRL = []
- -getTriplesRL (NilRL:<:_) = []
- -getTriplesRL (NilRL:<:_:<:_) = []
- -getTriplesRL (a:<:b:<:c:<:d) = seal2 (b:>c:>d) : getTriplesRL (a:<:b:<:c)
+withSingle
+ :: Merge p
+ => (forall wX wY. p wX wY -> r)
+ -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+withSingle prop (Sealed2 (WithStartState2 _ ms))
+ = case mergeableSequenceToRL ms of
+ _ :<: pp -> Just (prop pp)
+ _ -> Nothing
+
+withPair
+ :: Merge p
+ => (forall wX wY. (p :> p) wX wY -> r)
+ -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+withPair prop (Sealed2 (WithStartState2 _ ms))
+ = case mergeableSequenceToRL ms of
+ _ :<: pp1 :<: pp2 -> Just (prop (pp1 :> pp2))
+ _ -> Nothing
+
+withTriple
+ :: Merge p
+ => (forall wX wY. (p :> p :> p) wX wY -> r)
+ -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+withTriple prop (Sealed2 (WithStartState2 _ ms))
+ = case mergeableSequenceToRL ms of
+ _ :<: pp1 :<: pp2 :<: pp3 -> Just (prop (pp1 :> pp2 :> pp3))
+ _ -> Nothing
+
+withFork
+ :: Merge p
+ => (forall wX wY. (FL p :\/: FL p) wX wY -> r)
+ -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+-- We can't use (MergeableSequence p:\/: MergeableSequence p) as the input because
+-- the witnesses would be wrong, so just use MergeableSequence p and choose the
+-- ParMS cases.
+withFork prop (Sealed2 (WithStartState2 _ (ParMS ms1 ms2)))
+ = Just (prop (reverseRL (mergeableSequenceToRL ms1) :\/: reverseRL (mergeableSequenceToRL ms2)))
+withFork _ _ = Nothing
+
+withSequence
+ :: Merge p
+ => (forall wX wY. RL p wX wY -> r)
+ -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> r
+withSequence prop (Sealed2 (WithStartState2 _ ms))
+ = prop (mergeableSequenceToRL ms)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 55
- -import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
+import Darcs.Test.Patch.WithState ( WithEndState(..), PropagateShrink(..), ArbitraryState(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 128
+instance ArbitraryState model prim => ArbitraryState model (RepoPatchV1 prim) where
+ arbitraryState rStart = do
+ Sealed (WithEndState p rEnd) <- arbitraryState rStart
+ return (Sealed (WithEndState (PP p) rEnd))
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 8
- -import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
+import Darcs.Test.Patch.WithState ( PropagateShrink(..), ArbitraryState(..), WithEndState(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 15
+import Darcs.Patch.Witnesses.Sealed
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 22
+instance ArbitraryState model prim => ArbitraryState model (RepoPatchV2 prim) where
+ arbitraryState rStart = do
+ Sealed (WithEndState p rEnd) <- arbitraryState rStart
+ return (Sealed (WithEndState (Normal p) rEnd))
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 10
- -import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
+import Darcs.Test.Patch.WithState ( PropagateShrink(..), ArbitraryState(..), WithEndState(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 16
+import Darcs.Patch.Witnesses.Sealed
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 23
+instance ArbitraryState model prim => ArbitraryState model (RepoPatchV3 prim) where
+ arbitraryState rStart = do
+ Sealed (WithEndState p rEnd) <- arbitraryState rStart
+ return (Sealed (WithEndState (V3.Prim p) rEnd))
+
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 14
- -import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )
+import Darcs.Test.Patch.Arbitrary.Generic
+ ( Tree, flattenTree, G2(..), mapTree, MergeableSequence, mergeableSequenceToRL )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 31
- -import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal )
+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, Sealed2(..) )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 78
- - => WithStartModel (RL p) wX
+ => Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p))
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 80
- -propConsistentReorderings (WithStartModel start (Sealed ps)) =
+propConsistentReorderings (Sealed2 (WithStartState2 start ms)) =
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 95
+ ps = mergeableSequenceToRL ms
hunk ./harness/Darcs/Test/Patch/WithState.hs 78
- -
- --- | This is like 'WithStartState' but fixes the state type as @'ModelOf' p@ to
- --- avoid problems with ambiguous type variables. Note that the first type
- --- parameter here has kind @p::*->*->*@, whereas 'WithStartState' takes
- --- @p::*->*@.
- -data WithStartModel p wX = WithStartModel (ModelOf p wX) (Sealed (p wX))
- -
- -instance (Show1 (ModelOf p), Show2 p) => Show (WithStartModel p wX) where
- - showsPrec d (WithStartModel s (Sealed p)) =
- - showParen (d > appPrec) $
- - showString "WithStartModel " .
- - showsPrec1 (appPrec + 1) s . showString " " . showsPrec2 (appPrec + 1) p
- -
- -instance (Show1 (ModelOf p), Show2 p) => Show1 (WithStartModel p)
- -
[massive boilerplate reduction in test harness
Ben Franksen <ben.franksen at online.de>**20200216085332
Ignore-this: 2ffc7cabc51171648141e20e5832ffaf23eb3bfb8d90e6a8c6e7f0769bfefaf11622701a86927adc
This patch makes a number of invasive refactors in the test harness that
dramatically reduce the boilerplate of repeated instance Arbitrary
definitions. Here are the main ideas:
First, remove all instances for Sealed patches and keep only the ones for
Sealed2 patches. The generators and infrastructure have been refactored to
always take and generate Sealed2 patches. This has the beneficial
side-effect of cleaning up a lot of the types in the testing infrastructure.
For most of the remaining Arbitrary instances we can provide a single
generic instance. To make this possible we need to use the generic model
generator (aSmallRepo from the RepoModel class), which we always do except
for the RepoPatchV1 tests. My solution for this was to move all the
RepoPatchV1 tests into a separate module and throw out the tests that are
disabled for RepoPatchV1 anyway. Even with this out of the way, I needed to
refactor WithState and the class ArbitraryState to no longer take the
model/state as parameter, but rather use the type function ModelOf. This,
too, make the types simpler and signatures less verbose.
Additional minor cleanups:
- The TestGenerator/TestCondition/TestCheck machinery now lives in the
D.T.Patch.Utils module.
- Generalize qc_prim32/3 to qc_named_prim.
- Removed some redundant constraints.
- Renamed Darcs.Test.Util.TestResult.fromMaybe to avoid collision with the
well known Data.Maybe.fromMaybe
- Allow all darcs-lib extensions for darcs-test, too; cleanup module-local
extension pragmas.
] hunk ./darcs.cabal 599
+ Darcs.Test.Patch.RepoPatchV1
hunk ./darcs.cabal 625
+ BangPatterns
hunk ./darcs.cabal 629
- - ExistentialQuantification
+ DeriveDataTypeable
+ DeriveFunctor
+ EmptyDataDecls
hunk ./darcs.cabal 634
- - GADTSyntax
+ GADTs
+ GeneralizedNewtypeDeriving
hunk ./darcs.cabal 637
+ LambdaCase
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 62
- --- | Generate a patch to a certain state.
- -class ArbitraryStateIn s p where
- - arbitraryStateIn :: s wX -> Gen (p wX)
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 127
- -instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where
- - -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).
- - -- Note if we don't put a non-zero lower bound the first generated trees will
- - -- always have depth 0.
- - -- The minimum size of 3 means that we have a reasonable probability that the
- - -- Tree has at least one triple.
- - arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 128
- -arbitraryTree :: ArbitraryState s p => s wX -> Int -> Gen (Tree p wX)
+arbitraryTree :: ArbitraryState p => ModelOf p wX -> Int -> Gen (Tree p wX)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 201
- -class ( ArbitraryState (ModelOf prim) prim
+class ( ArbitraryState prim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 244
+-- | Generate a patch to a certain state.
+class ArbitraryStateIn s p where
+ arbitraryStateIn :: s wX -> Gen (p wX)
+
+instance (ArbitraryState p, s ~ ModelOf p) => ArbitraryStateIn s (Tree p) where
+ -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).
+ -- Note if we don't put a non-zero lower bound the first generated trees will
+ -- always have depth 0.
+ -- The minimum size of 3 means that we have a reasonable probability that the
+ -- Tree has at least one triple.
+ arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 259
- - , ArbitraryState model prim
+ , ArbitraryState prim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 280
- - -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> Maybe t)
- -commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))
+ -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
+ -> Maybe t
+commutePairFromTWFP handlePair (Sealed (WithStartState _ (TWFP n t)))
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 289
- - -> (WithStartState model (Tree (PrimOf p)) wX -> Maybe t)
- -commutePairFromTree handlePair (WithStartState _ t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+commutePairFromTree handlePair (Sealed (WithStartState _ t))
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 298
- - -> (WithStartState model (Tree (PrimOf p)) wX -> Maybe t)
- -commuteTripleFromTree handle (WithStartState _ t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+commuteTripleFromTree handle (Sealed (WithStartState _ t))
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 321
- - -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> Maybe t)
+ -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
+ -> Maybe t
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 327
- - -> (WithStartState model (Tree (PrimOf p)) wX -> Maybe t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 337
- - -> (WithStartState model (Tree (PrimOf p)) wX -> Maybe t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 361
- - , ArbitraryState model prim
+ , ArbitraryState prim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 592
- - , Commute p, Merge p
- - , ArbitraryState model p
+ , model ~ ModelOf p
+ , Merge p
+ , ArbitraryState p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 596
- - => ArbitraryState model (MergeableSequence p) where
+ => ArbitraryState (MergeableSequence p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 10
+import Darcs.Test.Patch.RepoModel
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 23
- -instance (FromPrim p, ArbitraryState model (PrimOf p))
- - => ArbitraryState model (Named p) where
+type instance ModelOf (Named p) = ModelOf (PrimOf p)
+
+instance (FromPrim p, ArbitraryState (PrimOf p))
+ => ArbitraryState (Named p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 24
- - , ArbitraryState (ModelOf p) (NamedPrim p)
+ , ArbitraryState (NamedPrim p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 39
- -instance ArbitraryState model prim => ArbitraryState model (NamedPrim prim) where
+instance ArbitraryState prim => ArbitraryState (NamedPrim prim) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 10
- -import Control.Monad ( liftM )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 149
- -ourSmallRepo :: Gen (FileUUIDModel wX)
- -ourSmallRepo = aSmallRepo
- -
- -instance ArbitraryState FileUUIDModel Prim where
+instance ArbitraryState Prim where
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 153
- -instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo
- -
+-- use the special generator for pairs
+arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))
+arbitraryPair = do
+ repo <- aSmallRepo
+ WithEndState pp repo' <- aPrimPair repo
+ return $ seal2 $ WithState repo pp repo'
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 161
- - arbitrary = makeS2Gen ourSmallRepo
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 163
- -instance Arbitrary (Sealed (Prim x)) where
- - arbitrary = makeSGen ourSmallRepo
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 164
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal2 pp
+ arbitrary = mapSeal2 wsPatch <$> arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 166
- -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal pp
- -
- -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel Prim)) where
- - arbitrary = makeWS2Gen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState Prim)) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 169
- -instance Arbitrary (Sealed (WithState FileUUIDModel Prim wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim) wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (Prim :> Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal2 $ WithState repo pp repo'
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel (Prim :> Prim) a)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal $ WithState repo pp repo'
- -
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim :> FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim :> FL Prim) a)) where
- - arbitrary = makeWSGen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where
+ arbitrary = arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 19
- -import Control.Monad ( liftM )
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 48
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 52
- -instance NullPatch Prim2 where
- - nullPatch (V2.Prim (Prim.FP _ fp)) = nullPatch fp
- - nullPatch p | IsEq <- isIdentity (V2.unPrim p) = IsEq
- - nullPatch _ = NotEq
- -
- -instance NullPatch Prim1 where
- - nullPatch (V1.Prim (Prim.FP _ fp)) = nullPatch fp
- - nullPatch p | IsEq <- isIdentity (V1.unPrim p) = IsEq
+instance NullPatch Prim.Prim where
+ nullPatch (Prim.FP _ fp) = nullPatch fp
+ nullPatch p | IsEq <- isIdentity p = IsEq
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 56
+deriving instance NullPatch Prim1
+deriving instance NullPatch Prim2
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 63
- -instance MightBeEmptyHunk Prim1 where
- - isEmptyHunk (V1.Prim (Prim.FP _ (Hunk _ [] []))) = True
- - isEmptyHunk _ = False
- -
- -instance MightBeEmptyHunk Prim2 where
- - isEmptyHunk (V2.Prim (Prim.FP _ (Hunk _ [] []))) = True
+instance MightBeEmptyHunk Prim.Prim where
+ isEmptyHunk (Prim.FP _ (Hunk _ [] [])) = True
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 66
+deriving instance MightBeEmptyHunk Prim1
+deriving instance MightBeEmptyHunk Prim2
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 71
- -
- -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim1))) where
- - arbitrary = do repo <- ourSmallRepo
- - liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo
- -
- -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim2))) where
- - arbitrary = do repo <- ourSmallRepo
- - liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 128
- -aHunkP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)
+aHunkP :: PrimPatch prim => (AnchoredPath, File) -> Gen (prim wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 135
- -aTokReplaceP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)
+aTokReplaceP :: PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 142
- -anAddFileP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
+anAddFileP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 150
- -aRmFileP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty file
- - -> prim wX wY
+aRmFileP :: PrimPatch prim
+ => AnchoredPath -- ^ Path of an empty file
+ -> prim wX wY
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 155
- -anAddDirP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
+anAddDirP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 163
- -aRmDirP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty directory
- - -> prim wX wY
+aRmDirP :: PrimPatch prim
+ => AnchoredPath -- ^ Path of an empty directory
+ -> prim wX wY
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 168
- -aMoveP :: forall prim wX wY . PrimPatch prim => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY)
+aMoveP :: PrimPatch prim
+ => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 292
- -hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY)
+hunkPairP :: PrimPatch prim => (AnchoredPath, File) -> Gen ((prim :> prim) wX wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 309
- -aPrimPair :: forall prim wX wY . (PrimPatch prim, ArbitraryState V1Model prim, ApplyState prim ~ RepoState V1Model) => V1Model wX -> Gen (WithEndState V1Model ((prim :> prim) wX) wY)
+aPrimPair :: ( PrimPatch prim
+ , ArbitraryState prim
+ , ApplyState prim ~ RepoState V1Model
+ , ModelOf prim ~ V1Model
+ )
+ => V1Model wX
+ -> Gen (WithEndState V1Model ((prim :> prim) wX) wY)
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 365
- -ourSmallRepo :: Gen (V1Model wX)
- -ourSmallRepo = aSmallRepo
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 368
- -instance ArbitraryState V1Model Prim1 where
- - arbitraryState s = seal <$> aPrim s
+-- use the special generator for pairs
+arbitraryPair :: ( PrimPatch prim
+ , ApplyState prim ~ Tree
+ , ArbitraryState prim
+ , ModelOf prim ~ V1Model
+ )
+ => Gen (Sealed2 (WithState (prim :> prim)))
+arbitraryPair = do
+ repo <- aSmallRepo
+ WithEndState pp repo' <- aPrimPair repo
+ return $ seal2 $ WithState repo pp repo'
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 380
- -instance ShrinkModel V1Model Prim1 where
- - shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s
- -
- -instance PropagateShrink Prim1 Prim1 where
- - propagateShrink = propagatePrim
+-- Prim1
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 382
- -instance ArbitraryState V1Model Prim2 where
+instance ArbitraryState Prim1 where
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 385
- -instance ShrinkModel V1Model Prim2 where
- - shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s
+instance ShrinkModel V1Model Prim1 where
+ shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 388
- -instance PropagateShrink Prim2 Prim2 where
+instance PropagateShrink Prim1 Prim1 where
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 391
- -instance Arbitrary (Sealed (Prim1 wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (Prim2 wA)) where
- - arbitrary = makeSGen ourSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 393
- - arbitrary = makeS2Gen ourSmallRepo
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 395
- -instance Arbitrary (Sealed2 Prim2) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -arbitrarySeal2 :: (PrimPatch prim, ApplyState prim ~ Tree,
- - ArbitraryState V1Model prim)
- - => Gen (Sealed2 (prim :> prim))
- -arbitrarySeal2 = do
- - repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal2 pp
- -
- -arbitrarySeal :: (PrimPatch prim, ApplyState prim ~ Tree,
- - ArbitraryState V1Model prim)
- - => Gen (Sealed ((:>) prim prim wX))
- -arbitrarySeal = do
- - repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal pp
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 396
- - arbitrary = arbitrarySeal2
+ arbitrary = mapSeal2 wsPatch <$> arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 398
- -instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where
- - arbitrary = arbitrarySeal2
+instance Arbitrary (Sealed2 (WithState Prim1)) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 401
- -instance Arbitrary (Sealed ((Prim1 :> Prim1) wA)) where
- - arbitrary = arbitrarySeal
+instance Arbitrary (Sealed2 (WithState (Prim1 :> Prim1))) where
+ arbitrary = arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 404
- -instance Arbitrary (Sealed ((Prim2 :> Prim2) wA)) where
- - arbitrary = arbitrarySeal
+-- Prim2
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 406
- -instance Arbitrary (Sealed2 (Prim1 :> Prim1 :> Prim1)) where
- - arbitrary = makeS2Gen ourSmallRepo
+instance ArbitraryState Prim2 where
+ arbitraryState s = seal <$> aPrim s
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 409
- -instance Arbitrary (Sealed ((Prim1 :> Prim1 :> Prim1) a)) where
- - arbitrary = makeSGen ourSmallRepo
+instance ShrinkModel V1Model Prim2 where
+ shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 412
- -instance Arbitrary (Sealed2 (FL Prim1)) where
- - arbitrary = makeS2Gen ourSmallRepo
+instance PropagateShrink Prim2 Prim2 where
+ propagateShrink = propagatePrim
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 415
- -instance Arbitrary (Sealed ((FL Prim1) wA)) where
- - arbitrary = makeSGen ourSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 416
- -instance Arbitrary (Sealed2 (FL Prim1 :> FL Prim1)) where
- - arbitrary = makeS2Gen ourSmallRepo
+instance Arbitrary (Sealed2 Prim2) where
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 419
- -instance Arbitrary (Sealed ((FL Prim1 :> FL Prim1) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model Prim1)) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model Prim1 wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim1) wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (Prim1 :> Prim1))) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal2 $ WithState repo pp repo'
- -
- -instance Arbitrary (Sealed (WithState V1Model (Prim1 :> Prim1) a)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal $ WithState repo pp repo'
- -
+instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where
+ arbitrary = mapSeal2 wsPatch <$> arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 422
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1))) where
- - arbitrary = makeWS2Gen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState Prim2)) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 425
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1 :> FL Prim1))) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim1 :> FL Prim1) a)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (Prim2 :> Prim2 :> Prim2)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((Prim2 :> Prim2 :> Prim2) a)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim2)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim2) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim2 :> FL Prim2)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim2 :> FL Prim2) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model Prim2)) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model Prim2 wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim2) wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (Prim2 :> Prim2))) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal2 $ WithState repo pp repo'
- -
- -instance Arbitrary (Sealed (WithState V1Model (Prim2 :> Prim2) a)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal $ WithState repo pp repo'
- -
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2))) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2 :> FL Prim2))) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim2 :> FL Prim2) a)) where
- - arbitrary = makeWSGen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState (Prim2 :> Prim2))) where
+ arbitrary = arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 25
- -ourSmallRepo :: Gen (FileUUIDModel wX)
- -ourSmallRepo = aSmallRepo
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 33
- -instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - fmap (unseal (seal2 . wesPatch)) $ arbitraryState repo
- -
- -
- -instance Arbitrary (Sealed2 Prim) where
- - arbitrary = makeS2Gen ourSmallRepo
+-- use the special generator for pairs
+arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))
+arbitraryPair = do
+ repo <- aSmallRepo
+ WithEndState pp repo' <- aPrimPair repo
+ return $ seal2 $ WithState repo pp repo'
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 40
- -instance Arbitrary (Sealed (Prim x)) where
- - arbitrary = makeSGen ourSmallRepo
+instance Arbitrary (Sealed2 Prim) where
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 44
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal2 pp
- -
- -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal pp
- -
- -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel Prim)) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel Prim wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim) wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (Prim :> Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal2 $ WithState repo pp repo'
- -
- -instance Arbitrary (Sealed (WithState FileUUIDModel (Prim :> Prim) a)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal $ WithState repo pp repo'
- -
- -
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
+ arbitrary = mapSeal2 wsPatch <$> arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 46
- -instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim :> FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState Prim)) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3FileUUID.hs 49
- -instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim :> FL Prim) a)) where
- - arbitrary = makeWSGen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where
+ arbitrary = arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 25
- -ourSmallRepo :: Gen (V1Model wX)
- -ourSmallRepo = aSmallRepo
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 33
- -instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - fmap (unseal (seal2 . wesPatch)) $ arbitraryState repo
- -
+-- use the special generator for pairs
+arbitraryPair :: Gen (Sealed2 (WithState (Prim :> Prim)))
+arbitraryPair = do
+ repo <- aSmallRepo
+ WithEndState pp repo' <- aPrimPair repo
+ return $ seal2 $ WithState repo pp repo'
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 41
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (Prim x)) where
- - arbitrary = makeSGen ourSmallRepo
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 44
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal2 pp
- -
- -instance Arbitrary (Sealed ((Prim :> Prim) wA)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp _ <- aPrimPair repo
- - return $ seal pp
- -
- -instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where
- - arbitrary = makeS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where
- - arbitrary = makeSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model Prim)) where
- - arbitrary = makeWS2Gen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model Prim wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim) wA)) where
- - arbitrary = makeWSGen ourSmallRepo
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal2 $ WithState repo pp repo'
- -
- -instance Arbitrary (Sealed (WithState V1Model (Prim :> Prim) a)) where
- - arbitrary = do repo <- ourSmallRepo
- - WithEndState pp repo' <- aPrimPair repo
- - return $ seal $ WithState repo pp repo'
- -
- -
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
+ arbitrary = mapSeal2 wsPatch <$> arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 46
- -instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where
- - arbitrary = makeWS2Gen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState Prim)) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV3V1.hs 49
- -instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where
- - arbitrary = makeWSGen ourSmallRepo
+instance Arbitrary (Sealed2 (WithState (Prim :> Prim))) where
+ arbitrary = arbitraryPair
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 20
- -import Darcs.Patch.Witnesses.Show
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 31
- - , Show2 p
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 18
- -{-# LANGUAGE TypeSynonymInstances #-}
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 53
- -import Darcs.Test.Patch.WithState ( WithEndState(..), PropagateShrink(..), ArbitraryState(..) )
+import Darcs.Test.Patch.RepoModel ( ModelOf )
+import Darcs.Test.Patch.WithState
+ ( ArbitraryState(..)
+ , PropagateShrink(..)
+ , WithEndState(..)
+ )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 89
+instance Arbitrary (Sealed ((Prim :> Prim) wX)) where
+ arbitrary = arbitraryP
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 95
- --- instance Arbitrary (Sealed2 (Prim :> Prim)) where
- - -- arbitrary = unseal Sealed2 <$> arbitraryP
+instance Arbitrary (Sealed2 (Prim :> Prim)) where
+ arbitrary = unseal Sealed2 <$> arbitraryP
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 134
- -instance ArbitraryState model prim => ArbitraryState model (RepoPatchV1 prim) where
+type instance ModelOf (RepoPatchV1 prim) = ModelOf prim
+
+instance ArbitraryState prim => ArbitraryState (RepoPatchV1 prim) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 22
- -instance ArbitraryState model prim => ArbitraryState model (RepoPatchV2 prim) where
+instance ArbitraryState prim => ArbitraryState (RepoPatchV2 prim) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 23
- -instance ArbitraryState model prim => ArbitraryState model (RepoPatchV3 prim) where
+instance ArbitraryState prim => ArbitraryState (RepoPatchV3 prim) where
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 79
+withStartState :: s wX -> p wX -> Sealed (WithStartState s p)
+withStartState s p = seal (WithStartState s p)
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 85
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 92
- - WithStartState (makeSimpleRepo "file" [BC.pack "j"])
+ withStartState (makeSimpleRepo "file" [BC.pack "j"])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 109
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 118
- - WithStartState
+ withStartState
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 129
- - WithStartState
+ withStartState
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 143
- - WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])
+ withStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 151
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 157
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 166
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 174
- - WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",
+ withStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 186
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 195
- - WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])
+ withStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 204
- - WithStartState (makeSimpleRepo "file" []) $
+ withStartState (makeSimpleRepo "file" []) $
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 212
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 219
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 225
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 231
- - WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])
+ withStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 240
- - WithStartState (makeSimpleRepo "file" [])
+ withStartState (makeSimpleRepo "file" [])
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 42
- - fromMaybe )
+ maybeFailed )
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 114
+ , model ~ ModelOf p
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 116
- - => WithState model p wA wB
+ => WithState p wA wB
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 212
+ , model ~ ModelOf p
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 217
- - -> WithState model (p :> p) wA wB
+ -> WithState (p :> p) wA wB
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 396
- - fromMaybe $
+ maybeFailed $
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 406
- - fromMaybe $
+ maybeFailed $
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 489
- - -> WithState (ModelOf prim) (prim :> prim) wA wB -> TestResult
+ -> WithState (prim :> prim) wA wB -> TestResult
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 51
- -import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 73
- -type Prim1 = V1.Prim
- -
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 224
- -type CommuteProperty = Sealed2 (Prim1 :> Prim1) -> Property
+type CommuteProperty = Sealed2 (Prim :> Prim) -> Property
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 227
- - forall wX wY . (Prim1 :> Prim1) wX wY -> Perhaps ((Prim1 :> Prim1) wX wY)
+ forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY)
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 235
- - q' :> p' <- f (V1.unPrim p :> V1.unPrim q)
- - return (V1.Prim q' :> V1.Prim p')
+ q' :> p' <- f (p :> q)
+ return (q' :> p')
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 308
- -doesFail :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool
+doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 314
- -does :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool
+does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool
hunk ./harness/Darcs/Test/Patch/Properties/V1Set2.hs 320
- -nontrivial :: WrappedCommuteFunction -> Prim1 wX wY -> Prim1 wY wZ -> Bool
+nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool
addfile ./harness/Darcs/Test/Patch/RepoPatchV1.hs
hunk ./harness/Darcs/Test/Patch/RepoPatchV1.hs 1
+-- Copyright (C) 2002-2005,2007 David Roundy
+--
+-- This program is free software; you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation; either version 2, or (at your option)
+-- any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with this program; see the file COPYING. If not, write to
+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+-- Boston, MA 02110-1301, USA.
+
+module Darcs.Test.Patch.RepoPatchV1 ( testSuite ) where
+
+import Darcs.Prelude
+
+import Test.Framework ( Test, testGroup )
+import Test.Framework.Providers.QuickCheck2 ( testProperty )
+
+import Darcs.Test.Patch.Utils ( testCases )
+
+import Darcs.Patch.Witnesses.Ordered
+import Darcs.Patch.Witnesses.Sealed
+import Darcs.Patch.Witnesses.Eq ( unsafeCompare )
+import Darcs.Patch.V1 as V1 ( RepoPatchV1 )
+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )
+import Darcs.Patch.Commute ( Commute(..) )
+
+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()
+
+import qualified Darcs.Test.Patch.Examples.Set1 as Ex
+
+import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1
+import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2
+import qualified Darcs.Test.Patch.Properties.Generic as PropG
+import Darcs.Test.Patch.Properties.GenericUnwitnessed ()
+
+import qualified Darcs.Test.Patch.Rebase as Rebase
+
+
+type RPV1 = V1.RepoPatchV1 V1.Prim
+
+unit_V1P1:: [Test]
+unit_V1P1 =
+ [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes
+ , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes
+ , testCases "known merges" Prop1.checkMerge Ex.knownMerges
+ , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs
+ , testCases "known canons" Prop1.checkCanon Ex.knownCanons
+ , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2
+ , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches
+ , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs
+ , testCases "merge properties: merge either way valid" PropG.mergeEitherWayValid Ex.mergePairs
+ , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs
+ , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches
+ , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches
+ , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed
+ , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs
+ ]
+
+qc_V1P1 :: [Test]
+qc_V1P1 =
+ [
+ testProperty "show and read work right" (unseal Prop2.propReadShow)
+ ]
+ ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute"
+ ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct"
+ ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail"
+ ++
+ [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse
+ -- , testProperty "conflict resolution is valid" Prop.propResolveConflictsValid
+ , testProperty "a patch followed by its inverse is identity"
+ Prop2.propPatchAndInverseIsIdentity
+ , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough
+ , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency
+ , testProperty "merges are valid" Prop2.propMergeValid
+ , testProperty "inverses being valid" Prop2.propInverseValid
+ , testProperty "other inverse being valid" Prop2.propOtherInverseValid
+ -- The patch generator isn't smart enough to generate correct test cases for
+ -- the following: (which will be obsoleted soon, anyhow)
+ -- , testProperty "the order dependence of unravel" Prop.propUnravelOrderIndependent
+ -- , testProperty "the unravelling of three merges" Prop.propUnravelThreeMerge
+ -- , testProperty "the unravelling of a merge of a sequence" Prop.propUnravelSeqMerge
+ , testProperty "the order of commutes" Prop2.propCommuteEitherOrder
+ , testProperty "commute either way" Prop2.propCommuteEitherWay
+ , testProperty "the double commute" Prop2.propCommuteTwice
+ , testProperty "merges commute and are well behaved"
+ Prop2.propMergeIsCommutableAndCorrect
+ , testProperty "merges can be swapped" Prop2.propMergeIsSwapable
+ , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable
+ ]
+
+testSuite :: Test
+testSuite =
+ testGroup "RepoPatchV1"
+ [ testGroup "using V1.Prim wrapper for Prim.V1" $
+ unit_V1P1 ++ qc_V1P1 ++
+ [ testGroup "Rebase patches" $ Rebase.testSuite @RPV1 ]
+ ]
hunk ./harness/Darcs/Test/Patch/Utils.hs 2
- - ( testConditional, testConditionalMaybe, testStringList )
- - where
+ ( testConditional
+ , testConditionalMaybe
+ , testStringList
+ , TestGenerator(..)
+ , TestCondition(..)
+ , TestCheck(..)
+ , PropList
+ , properties
+ , testCases
+ , fromNothing
+ ) where
hunk ./harness/Darcs/Test/Patch/Utils.hs 16
+import Data.Maybe ( fromMaybe )
+
hunk ./harness/Darcs/Test/Patch/Utils.hs 24
+import Darcs.Test.Util.TestResult
+
hunk ./harness/Darcs/Test/Patch/Utils.hs 54
+
+-- | Run a test function on a set of data, using HUnit. The test function should
+-- return @Nothing@ upon success and a @Just x@ upon failure.
+testCases :: String -- ^ The test name
+ -> (a -> TestResult) -- ^ The test function
+ -> [a] -- ^ The test data
+ -> Test
+testCases name test datas = testCase name (mapM_ (assertNotFailed . test) datas)
+
+class HasDefault a where
+ def :: a
+
+instance HasDefault Bool where
+ def = False
+
+instance HasDefault TestResult where
+ def = rejected
+
+newtype TestGenerator thing gen =
+ TestGenerator (forall t. HasDefault t => (forall wX wY. thing wX wY -> t) -> (gen -> Maybe t))
+
+newtype TestCondition thing =
+ TestCondition (forall wX wY. thing wX wY -> Bool)
+
+newtype TestCheck thing t =
+ TestCheck (forall wX wY. thing wX wY -> t)
+
+type PropList what gen = String -> TestGenerator what gen -> [Test]
+
+fromNothing :: HasDefault a => Maybe a -> a
+fromNothing = fromMaybe def
+
+properties :: forall thing gen. (Show gen, Arbitrary gen)
+ => TestGenerator thing gen
+ -> String -> String
+ -> forall t. (Testable t, HasDefault t) => [(String, TestCondition thing, TestCheck thing t)]
+ -> [Test]
+properties (TestGenerator gen) prefix genname tests =
+ [cond name condition check | (name, condition, check) <- tests]
+ where
+ cond ::
+ forall testable. (Testable testable, HasDefault testable)
+ => String
+ -> TestCondition thing
+ -> TestCheck thing testable
+ -> Test
+ cond t (TestCondition c) (TestCheck p) =
+ testConditional
+ (prefix ++ " (" ++ genname ++ "): " ++ t)
+ (fromMaybe def . gen c)
+ (gen p)
hunk ./harness/Darcs/Test/Patch/WSub.hs 89
- -instance WSub prim prim => WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where
+instance WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 1
- -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
- -
- -
- -module Darcs.Test.Patch.WithState
- - where
+{-# LANGUAGE UndecidableInstances #-}
+module Darcs.Test.Patch.WithState where
hunk ./harness/Darcs/Test/Patch/WithState.hs 27
- -data WithState s p wX wY = WithState {
- - wsStartState :: s wX
+data WithState p wX wY = WithState {
+ wsStartState :: (ModelOf p) wX
hunk ./harness/Darcs/Test/Patch/WithState.hs 30
- - , wsEndState :: s wY
+ , wsEndState :: (ModelOf p) wY
hunk ./harness/Darcs/Test/Patch/WithState.hs 32
- - deriving Eq
hunk ./harness/Darcs/Test/Patch/WithState.hs 33
- -instance (Show1 s, Show2 p) => Show (WithState s p wX wY) where
+type instance ModelOf (WithState p) = ModelOf p
+
+instance (Show1 (ModelOf p), Show2 p) => Show (WithState p wX wY) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 44
- -instance (Show1 s, Show2 p) => Show2 (WithState s p)
+instance (Show1 (ModelOf p), Show2 p) => Show1 (WithState p wA)
+
+instance (Show1 (ModelOf p), Show2 p) => Show2 (WithState p)
hunk ./harness/Darcs/Test/Patch/WithState.hs 103
- -class ArbitraryState s p where
- - arbitraryState :: s wX -> Gen (Sealed (WithEndState s (p wX)))
+class ArbitraryState p where
+ arbitraryState :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (p wX)))
hunk ./harness/Darcs/Test/Patch/WithState.hs 106
- -instance ArbitraryState s p => ArbitraryState s (WithState s p) where
+instance ArbitraryState p => ArbitraryState (WithState p) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 110
+type instance ModelOf (p :> p) = ModelOf p
hunk ./harness/Darcs/Test/Patch/WithState.hs 112
- -instance (ArbitraryState s p, ArbitraryState s q) => ArbitraryState s (p :> q) where
+instance ArbitraryState p => ArbitraryState (p :> p) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 117
- -arbitraryFL :: ArbitraryState s p => forall wX . Int -> s wX -> Gen (Sealed (WithEndState s (FL p wX)))
+{- the type instance overlaps!
+type instance ModelOf (p :> p :> p) = ModelOf p
+
+instance ArbitraryState p => ArbitraryState (p :> p :> p) where
+-}
+
+arbitraryTriple :: ArbitraryState p
+ => ModelOf p wX
+ -> Gen (Sealed (WithEndState (ModelOf p) ((p :> p :> p) wX)))
+arbitraryTriple s = do
+ Sealed (WithEndState p1 s') <- arbitraryState s
+ Sealed (WithEndState p2 s'') <- arbitraryState s'
+ Sealed (WithEndState p3 s''') <- arbitraryState s''
+ return $ seal $ WithEndState (p1 :> p2 :> p3) s'''
+
+arbitraryFL ::
+ ArbitraryState p
+ => forall wX. Int -> ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (FL p wX)))
hunk ./harness/Darcs/Test/Patch/WithState.hs 140
- -instance ArbitraryState s p => ArbitraryState s (FL p) where
+instance ArbitraryState p => ArbitraryState (FL p) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 145
- -makeS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 p)
+makeS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 p)
hunk ./harness/Darcs/Test/Patch/WithState.hs 150
- -makeSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (p wX))
+makeSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (p wX))
hunk ./harness/Darcs/Test/Patch/WithState.hs 155
- -makeWS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 (WithState s p))
+makeWS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 (WithState p))
hunk ./harness/Darcs/Test/Patch/WithState.hs 160
- -makeWSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (WithState s p wX))
+makeWSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (WithState p wX))
hunk ./harness/Darcs/Test/Patch/WithState.hs 165
- -instance (Show2 p, Show1 s) => Show1 ((WithState s p) wA)
- -
hunk ./harness/Darcs/Test/Patch/WithState.hs 270
- - ( ArbitraryState s p, Shrinkable p, RepoModel s
+ ( ArbitraryState p, Shrinkable p, RepoModel s
hunk ./harness/Darcs/Test/Patch.hs 1
- -{-# LANGUAGE PolyKinds #-}
hunk ./harness/Darcs/Test/Patch.hs 25
- -import Test.Framework.Providers.HUnit ( testCase )
hunk ./harness/Darcs/Test/Patch.hs 26
- -import Test.QuickCheck.Arbitrary( Arbitrary )
- -import Test.QuickCheck( Testable )
+import Test.QuickCheck( Arbitrary(..) )
hunk ./harness/Darcs/Test/Patch.hs 28
- -import Darcs.Test.Util.TestResult ( TestResult, fromMaybe, rejected, assertNotFailed )
- -import Darcs.Test.Patch.Utils ( testConditional )
+import Darcs.Test.Util.TestResult ( TestResult, maybeFailed )
+import Darcs.Test.Patch.Utils
+ ( PropList
+ , TestCheck(..)
+ , TestCondition(..)
+ , TestGenerator(..)
+ , properties
+ , testCases
+ , testConditional
+ , fromNothing
+ )
hunk ./harness/Darcs/Test/Patch.hs 42
- -import Darcs.Patch.Witnesses.Eq ( Eq2, unsafeCompare )
+import Darcs.Patch.Witnesses.Eq ( Eq2 )
hunk ./harness/Darcs/Test/Patch.hs 49
- -import Darcs.Patch.V1 as V1 ( RepoPatchV1 )
hunk ./harness/Darcs/Test/Patch.hs 65
- -import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()
hunk ./harness/Darcs/Test/Patch.hs 68
- -import Darcs.Test.Patch.Arbitrary.Shrink
+import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable )
hunk ./harness/Darcs/Test/Patch.hs 73
- - , ShrinkModel, PropagateShrink
+ , PropagateShrink, ShrinkModel
+ , makeS2Gen, makeWS2Gen
+ , arbitraryTriple, wesPatch
hunk ./harness/Darcs/Test/Patch.hs 81
- -import qualified Darcs.Test.Patch.Examples.Set1 as Ex
hunk ./harness/Darcs/Test/Patch.hs 84
- -import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1
- -import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2
hunk ./harness/Darcs/Test/Patch.hs 97
- -class HasDefault a where
- - def :: a
+-- Generic Arbitrary instances
hunk ./harness/Darcs/Test/Patch.hs 99
- -fromNothing :: HasDefault a => Maybe a -> a
- -fromNothing Nothing = def
- -fromNothing (Just x) = x
+-- We define them here so they don't overlap with those for RepoPatchV1,
+-- which use a different generator for V1Model.
hunk ./harness/Darcs/Test/Patch.hs 102
- -instance HasDefault Bool where
- - def = False
+type ArbitraryModel p = (RepoModel (ModelOf p), ArbitraryState p)
hunk ./harness/Darcs/Test/Patch.hs 104
- -instance HasDefault TestResult where
- - def = rejected
+instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p))) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch.hs 107
- -newtype TestGenerator thing gen =
- - TestGenerator (forall t ctx. HasDefault t => (forall wX wY. thing wX wY -> t) -> (gen ctx -> Maybe t))
+instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p :> FL p))) where
+ arbitrary = makeWS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch.hs 110
- -newtype TestCondition thing =
- - TestCondition (forall wX wY. thing wX wY -> Bool)
+instance ArbitraryModel p => Arbitrary (Sealed2 (FL p :> FL p)) where
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch.hs 113
- -newtype TestCheck thing t =
- - TestCheck (forall wX wY. thing wX wY -> t)
+instance ArbitraryModel p => Arbitrary (Sealed2 (FL p)) where
+ arbitrary = makeS2Gen aSmallRepo
hunk ./harness/Darcs/Test/Patch.hs 116
- -arbitraryThing :: x -> TestGenerator thing (thing x)
- -arbitraryThing _ = TestGenerator (\f p -> Just (f p))
+instance ArbitraryModel p => Arbitrary (Sealed2 (p :> p :> p)) where
+ arbitrary = unseal (seal2 . wesPatch) <$> (aSmallRepo >>= arbitraryTriple)
hunk ./harness/Darcs/Test/Patch.hs 119
- --- | Run a test function on a set of data, using HUnit. The test function should
- --- return @Nothing@ upon success and a @Just x@ upon failure.
- -testCases :: String -- ^ The test name
- - -> (a -> TestResult) -- ^ The test function
- - -> [a] -- ^ The test data
- - -> Test
- -testCases name test datas = testCase name (mapM_ (assertNotFailed . test) datas)
- -
- -unit_V1P1:: [Test]
- -unit_V1P1 =
- - [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes
- - , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes
- - , testCases "known merges" Prop1.checkMerge Ex.knownMerges
- - , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs
- - , testCases "known canons" Prop1.checkCanon Ex.knownCanons
- - , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2
- - , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches
- - , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs
- - , testCases "merge properties: merge either way valid" PropG.mergeEitherWayValid Ex.mergePairs
- - , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs
- - , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches
- - , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches
- - , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed
- - , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs
- - ]
+-- End generic instances
hunk ./harness/Darcs/Test/Patch.hs 149
- -qc_prim :: forall prim wA model.
- - (TestablePrim prim, Show2 prim
- - , model ~ ModelOf prim
+arbitraryThing :: TestGenerator thing (Sealed2 thing)
+arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))
+
+qc_prim :: forall prim.
+ ( TestablePrim prim
+ , Show2 prim
hunk ./harness/Darcs/Test/Patch.hs 158
- - , Show1 (prim wA)
hunk ./harness/Darcs/Test/Patch.hs 159
- - , Arbitrary (Sealed2 (FL prim))
- - , Arbitrary (Sealed ((prim :> prim) wA))
- - , Arbitrary (Sealed ((prim :> prim :> prim) wA))
- - , Arbitrary (Sealed (prim wA))
- - , Arbitrary (Sealed (FL prim wA))
- - , Arbitrary (Sealed ((FL prim :> FL prim) wA))
- - , Arbitrary (Sealed (WithState model prim wA))
- - , Arbitrary (Sealed (WithState model (FL prim) wA))
- - , Arbitrary (Sealed2 (WithState model (prim :> prim)))
- - , Arbitrary (Sealed ((WithState model (prim :> prim)) wA))
- - , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) wA))
+ , Arbitrary (Sealed2 (prim :> prim))
+ , Arbitrary (Sealed2 (WithState prim))
+ , Arbitrary (Sealed2 (WithState (prim :> prim)))
hunk ./harness/Darcs/Test/Patch.hs 169
- - (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult)
+ (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState (prim :> prim)) -> TestResult)
hunk ./harness/Darcs/Test/Patch.hs 173
- - [ pair_properties @prim "arbitrary" arbitraryThing'
- - , pair_properties @(FL prim) "arbitrary FL" arbitraryThing'
- - , coalesce_properties @prim "arbitrary" arbitraryThing'
- - , prim_commute_properties @prim "arbitrary" arbitraryThing'
- - , prim_commute_properties @(FL prim) "arbitrary FL" arbitraryThing'
- - , patch_properties @prim "arbitrary" arbitraryThing'
- - , patch_properties @(FL prim) "arbitrary FL" arbitraryThing'
- - , patch_repo_properties @prim "arbitrary" arbitraryThing'
- - , patch_repo_properties @(FL prim) "arbitrary FL" arbitraryThing'
- - , pair_repo_properties @prim "arbitrary" arbitraryThing'
- - , pair_repo_properties @(FL prim) "arbitrary FL" arbitraryThing'
- - , triple_properties @prim "arbitrary" arbitraryThing'
+ [ pair_properties @prim "arbitrary" arbitraryThing
+ , pair_properties @(FL prim) "arbitrary FL" arbitraryThing
+ , coalesce_properties @prim "arbitrary" arbitraryThing
+ , prim_commute_properties @prim "arbitrary" arbitraryThing
+ , prim_commute_properties @(FL prim) "arbitrary FL" arbitraryThing
+ , patch_properties @prim "arbitrary" arbitraryThing
+ , patch_properties @(FL prim) "arbitrary FL" arbitraryThing
+ , patch_repo_properties @prim "arbitrary" arbitraryThing
+ , patch_repo_properties @(FL prim) "arbitrary FL" arbitraryThing
+ , pair_repo_properties @prim "arbitrary" arbitraryThing
+ , pair_repo_properties @(FL prim) "arbitrary FL" arbitraryThing
+ , triple_properties @prim "arbitrary" arbitraryThing
hunk ./harness/Darcs/Test/Patch.hs 191
- - where
- - arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator
hunk ./harness/Darcs/Test/Patch.hs 192
- -qc_prim32 :: [Test]
- -qc_prim32 =
- - qc_prim @(NamedPrim V2.Prim) ++
- - [ testProperty
- - "prim inverse doesn't commute"
- - (unseal2 $ PropG.inverseDoesntCommute :: Sealed2 (NamedPrim V2.Prim) -> TestResult)
- - ]
- -
- -qc_prim33 :: [Test]
- -qc_prim33 =
- - qc_prim @(NamedPrim FileUUID.Prim) ++
+qc_named_prim :: forall prim.
+ ( TestablePrim prim
+ , Show2 prim
+ , Show1 (ModelOf (NamedPrim prim))
+ , MightBeEmptyHunk prim
+ , Arbitrary (Sealed2 (NamedPrim prim))
+ , Arbitrary (Sealed2 (NamedPrim prim :> NamedPrim prim))
+ , Arbitrary (Sealed2 (WithState (NamedPrim prim)))
+ , Arbitrary (Sealed2 (WithState (NamedPrim prim :> NamedPrim prim)))
+ ) => [Test]
+qc_named_prim =
+ qc_prim @(NamedPrim prim) ++
hunk ./harness/Darcs/Test/Patch.hs 206
- - (unseal2 $ PropG.inverseDoesntCommute :: Sealed2 (NamedPrim FileUUID.Prim) -> TestResult)
+ (unseal2 $ PropG.inverseDoesntCommute :: Sealed2 (NamedPrim prim) -> TestResult)
hunk ./harness/Darcs/Test/Patch.hs 213
+ , ShrinkModel (ModelOf prim) prim
+ , PropagateShrink prim prim
hunk ./harness/Darcs/Test/Patch.hs 216
- - , ShrinkPrim prim
hunk ./harness/Darcs/Test/Patch.hs 234
- - consistent = fromMaybe . isConsistent
+ consistent = maybeFailed . isConsistent
hunk ./harness/Darcs/Test/Patch.hs 240
+ , ShrinkModel (ModelOf prim) prim
+ , PropagateShrink prim prim
hunk ./harness/Darcs/Test/Patch.hs 243
- - , ShrinkPrim prim
hunk ./harness/Darcs/Test/Patch.hs 264
- - , ArbitraryState (ModelOf p) p
+ , ArbitraryState p
hunk ./harness/Darcs/Test/Patch.hs 292
- - , ArbitraryState (ModelOf p) p
+ , ArbitraryState p
hunk ./harness/Darcs/Test/Patch.hs 340
- -properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen))
- - => TestGenerator thing gen
- - -> String -> String
- - -> forall t. (Testable t, HasDefault t) => [(String, TestCondition thing, TestCheck thing t)]
- - -> [Test]
- -properties (TestGenerator gen) prefix genname tests =
- - [ cond name condition check | (name, condition, check) <- tests ]
- - where cond :: forall testable. (Testable testable, HasDefault testable)
- - => String -> TestCondition thing -> TestCheck thing testable -> Test
- - cond t (TestCondition c) (TestCheck p) =
- - testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ fromNothing . gen c) (unseal $ gen p)
- -
- -type PropList what gen = String -> TestGenerator what gen -> [Test]
- -
hunk ./harness/Darcs/Test/Patch.hs 341
- - . ( Show1 gen, Arbitrary (Sealed gen), MightHaveDuplicate p
+ . ( Show gen, Arbitrary gen, MightHaveDuplicate p
hunk ./harness/Darcs/Test/Patch.hs 355
- - . ( Show1 gen, Arbitrary (Sealed gen), TestablePrim p
+ . ( Show gen, Arbitrary gen, TestablePrim p
hunk ./harness/Darcs/Test/Patch.hs 368
- - . (Show1 gen, Arbitrary (Sealed gen), Commute p, Invert p, ShowPatchBasic p, Eq2 p)
+ . (Show gen, Arbitrary gen, Commute p, Invert p, ShowPatchBasic p, Eq2 p)
hunk ./harness/Darcs/Test/Patch.hs 377
- - ( Show1 gen
- - , Arbitrary (Sealed gen)
+ ( Show gen
+ , Arbitrary gen
hunk ./harness/Darcs/Test/Patch.hs 391
- - . ( Show1 gen, Arbitrary (Sealed gen)
+ . ( Show gen, Arbitrary gen
hunk ./harness/Darcs/Test/Patch.hs 396
- - => PropList (WithState (ModelOf p) p) gen
+ => PropList (WithState p) gen
hunk ./harness/Darcs/Test/Patch.hs 403
- - ( Show1 gen, Arbitrary (Sealed gen), Commute p
+ ( Show gen, Arbitrary gen, Commute p
hunk ./harness/Darcs/Test/Patch.hs 417
- - ( Show1 gen, Arbitrary (Sealed gen), Commute p
+ ( Show gen, Arbitrary gen, Commute p
hunk ./harness/Darcs/Test/Patch.hs 434
- - ( Show1 gen
- - , Arbitrary (Sealed gen)
+ ( Show gen
+ , Arbitrary gen
hunk ./harness/Darcs/Test/Patch.hs 443
- - => PropList (WithState (ModelOf p) (p :> p)) gen
+ => PropList (WithState (p :> p)) gen
hunk ./harness/Darcs/Test/Patch.hs 451
- -qc_V1P1 :: [Test]
- -qc_V1P1 =
- - [
- - testProperty "show and read work right" (unseal Prop2.propReadShow)
- - ]
- - ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute"
- - ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct"
- - ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail"
- - ++
- - [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse
- - -- , testProperty "conflict resolution is valid" Prop.propResolveConflictsValid
- - , testProperty "a patch followed by its inverse is identity"
- - Prop2.propPatchAndInverseIsIdentity
- - , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough
- - , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency
- - , testProperty "merges are valid" Prop2.propMergeValid
- - , testProperty "inverses being valid" Prop2.propInverseValid
- - , testProperty "other inverse being valid" Prop2.propOtherInverseValid
- - -- The patch generator isn't smart enough to generate correct test cases for
- - -- the following: (which will be obsoleted soon, anyhow)
- - -- , testProperty "the order dependence of unravel" Prop.propUnravelOrderIndependent
- - -- , testProperty "the unravelling of three merges" Prop.propUnravelThreeMerge
- - -- , testProperty "the unravelling of a merge of a sequence" Prop.propUnravelSeqMerge
- - , testProperty "the order of commutes" Prop2.propCommuteEitherOrder
- - , testProperty "commute either way" Prop2.propCommuteEitherWay
- - , testProperty "the double commute" Prop2.propCommuteTwice
- - , testProperty "merges commute and are well behaved"
- - Prop2.propMergeIsCommutableAndCorrect
- - , testProperty "merges can be swapped" Prop2.propMergeIsSwapable
- - , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable
- -
- - ] -- the following properties are disabled, because they routinely lead to
- - -- exponential cases, making the tests run for ever and ever; nevertheless,
- - -- we would expect them to hold
- - ++
- - (if False
- - then
- - merge_properties @(V1.RepoPatchV1 Prim1) "tree" (TestGenerator mergePairFromTree) ++
- - merge_properties @(V1.RepoPatchV1 Prim1) "twfp" (TestGenerator mergePairFromTWFP) ++
- - pair_properties @(V1.RepoPatchV1 Prim1) "tree" (TestGenerator commutePairFromTree) ++
- - pair_properties @(V1.RepoPatchV1 Prim1) "twfp" (TestGenerator commutePairFromTWFP)
- - else [])
- -
hunk ./harness/Darcs/Test/Patch.hs 461
- - , repoPatchV1Tests
hunk ./harness/Darcs/Test/Patch.hs 471
- - , testGroup "NamedPrim over V2.Prim" qc_prim32
- - , testGroup "NamedPrim over Prim.FileUUID" qc_prim33
+ , testGroup "NamedPrim over V2.Prim" $ qc_named_prim @Prim2
+ , testGroup "NamedPrim over Prim.FileUUID" $ qc_named_prim @FileUUID.Prim
hunk ./harness/Darcs/Test/Patch.hs 474
- - repoPatchV1Tests = testGroup "RepoPatchV1"
- - [ testGroup "using V1.Prim wrapper for Prim.V1" $
- - unit_V1P1 ++ qc_V1P1 ++
- - general_patchTests @(V1.RepoPatchV1 Prim1)
- - ]
hunk ./harness/Darcs/Test/Patch.hs 488
- - general_patchTests @(RepoPatchV2 FileUUID.Prim)
+ general_patchTests @(RepoPatchV3 FileUUID.Prim)
hunk ./harness/Darcs/Test/Util/TestResult.hs 8
- - , fromMaybe
+ , maybeFailed
hunk ./harness/Darcs/Test/Util/TestResult.hs 49
- -fromMaybe :: Maybe Doc -> TestResult
- -fromMaybe Nothing = succeeded
- -fromMaybe (Just errMsg) = failed errMsg
+maybeFailed :: Maybe Doc -> TestResult
+maybeFailed Nothing = succeeded
+maybeFailed (Just errMsg) = failed errMsg
hunk ./harness/test.hs 10
+import qualified Darcs.Test.Patch.RepoPatchV1
hunk ./harness/test.hs 49
- - ] ++ Darcs.Test.Patch.testSuite
+ ] ++ (Darcs.Test.Patch.RepoPatchV1.testSuite : Darcs.Test.Patch.testSuite)
hunk ./harness/test.hs 307
+ | takeBaseName path == "darcs-test" ] ++
+ [takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x"
+ </> "darcs" </> "noopt" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)
[harness: move legacy Tree stuff into its own module
Ben Franksen <ben.franksen at online.de>**20200216190323
Ignore-this: 820e270953d686254d4834fc4be7ce526615a49965246f30fe1a379ad5d65cb20fd26ab3db3ee14e
D.T.P.Arbitrary.Generic has grown quite a lot with the new shrinker, so it
makes sense to split it. Besides this gets the old Tree based generator out
of the way, making it easier to eventually get rid of it.
] hunk ./darcs.cabal 584
+ Darcs.Test.Patch.Arbitrary.PatchTree
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 1
- -{-# LANGUAGE UndecidableInstances, ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 3
- - ( Tree(..)
- - , TreeWithFlattenPos(..)
- - , G2(..)
- - , ArbitraryPrim(..)
+ ( ArbitraryPrim(..)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 10
- - , flattenOne
- - , flattenTree
- - , mapTree
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 14
- - , commutePairFromTree
- - , mergePairFromTree
- - , commuteTripleFromTree
- - , mergePairFromCommutePair
- - , commutePairFromTWFP
- - , mergePairFromTWFP
- - , getPairs
- - , getTriples
- - , patchFromTree
- - , canonizeTree
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 40
- -import Darcs.Patch.FromPrim ( FromPrim(..), PrimPatchBase, PrimOf )
+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 46
- --- | A 'Tree' of patches 'p' starting at state 'wX' simulating
- --- several branches of a repo. The end states of the branches
- --- may of course differ.
- -data Tree p wX where
- - NilTree :: Tree p wX
- - SeqTree :: p wX wY -> Tree p wY -> Tree p wX
- - ParTree :: Tree p wX -> Tree p wX -> Tree p wX
- -
- -mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX
- -mapTree _ NilTree = NilTree
- -mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)
- -mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)
- -
- -instance Show2 p => Show (Tree p wX) where
- - showsPrec _ NilTree = showString "NilTree"
- - showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .
- - showsPrec2 (appPrec + 1) a . showString " " .
- - showsPrec (appPrec + 1) t
- - showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .
- - showsPrec (appPrec + 1) t1 . showString " " .
- - showsPrec (appPrec + 1) t2
- -
- -instance Show2 p => Show1 (Tree p)
- -
- -instance Show2 p => Show1 (TreeWithFlattenPos p)
- -
- --- | The number of patches in a 'Tree'. This is the (common) length of all
- --- elements of 'flattenTree'.
- -sizeTree :: Tree p wX -> Int
- -sizeTree NilTree = 0
- -sizeTree (SeqTree _ t) = 1 + sizeTree t
- -sizeTree (ParTree t1 t2) = sizeTree t1 + sizeTree t2
- -
- --- | The number of successive pairs in a flattened 'Tree'.
- -numPairs :: Tree p wX -> Int
- -numPairs t =
- - case sizeTree t of
- - 0 -> 0
- - s -> s - 1
- -
- --- | The number of successive triples in a flattened 'Tree'.
- -numTriples :: Tree p wX -> Int
- -numTriples t =
- - case sizeTree t of
- - 0 -> 0
- - 1 -> 0
- - s -> s - 2
- -
- -newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }
- -
- --- | All possible ways that the several branches of a 'Tree' can be
- --- merged into a linear sequence.
- -flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)
- -flattenTree NilTree = seal $ G2 $ return NilFL
- -flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t
- -flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2)) =
- - seal $
- - G2 $ do
- - ps1 <- unG2 gpss1
- - ps2 <- unG2 gpss2
- - ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)
- - -- We can't prove that the existential type in the result
- - -- of merge will be the same for each pair of ps1 and ps2.
- - map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']
- -
- --- | Generate a tree of patches, bounded by depth.
- -arbitraryTree :: ArbitraryState p => ModelOf p wX -> Int -> Gen (Tree p wX)
- -arbitraryTree rm depth
- - | depth == 0 = return NilTree
- - -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.
- - -- For the purpose of this module empty trees are useless, but even when
- - -- NilTree case is omitted there is still a small percentage of empty trees
- - -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.
- - | otherwise =
- - frequency
- - [ ( 1
- - , do Sealed (WithEndState p rm') <- arbitraryState rm
- - t <- arbitraryTree rm' (depth - 1)
- - return (SeqTree p t))
- - , ( 3
- - , do t1 <- arbitraryTree rm (depth - 1)
- - t2 <- arbitraryTree rm (depth - 1)
- - return (ParTree t1 t2))
- - ]
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 131
- -
- --- | Canonize a 'Tree', removing any dead branches.
- -canonizeTree :: NullPatch p => Tree p wX -> Tree p wX
- -canonizeTree NilTree = NilTree
- -canonizeTree (ParTree t1 t2)
- - | NilTree <- canonizeTree t1 = canonizeTree t2
- - | NilTree <- canonizeTree t2 = canonizeTree t1
- - | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)
- -canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t
- - | otherwise = SeqTree p (canonizeTree t)
- -
- -
- --- | Generate a patch to a certain state.
- -class ArbitraryStateIn s p where
- - arbitraryStateIn :: s wX -> Gen (p wX)
- -
- -instance (ArbitraryState p, s ~ ModelOf p) => ArbitraryStateIn s (Tree p) where
- - -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).
- - -- Note if we don't put a non-zero lower bound the first generated trees will
- - -- always have depth 0.
- - -- The minimum size of 3 means that we have a reasonable probability that the
- - -- Tree has at least one triple.
- - arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth
- -
- -instance ( RepoModel model
- - , ArbitraryPrim prim
- - , model ~ ModelOf prim
- - , ArbitraryState prim
- - ) =>
- - Arbitrary (Sealed (WithStartState model (Tree prim))) where
- - arbitrary = do
- - repo <- aSmallRepo
- - Sealed . WithStartState repo <$>
- - (canonizeTree <$> arbitraryStateIn repo) `suchThat` (\t -> numTriples t >= 1)
- -
- -flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)
- -flattenOne NilTree = seal NilFL
- -flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromAnonymousPrim p :>: ps)
- -flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =
- - case merge (ps1 :\/: ps2) of
- - ps2' :/\: _ -> seal (ps1 +>+ ps2')
- -
- --- | A 'Tree' together with some number that is no greater than
- --- the number of pairs in the 'Tree'.
- -data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)
- -
- -commutePairFromTWFP :: (FromPrim p, Merge p)
- - => (forall wY wZ . (p :> p) wY wZ -> t)
- - -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
- - -> Maybe t
- -commutePairFromTWFP handlePair (Sealed (WithStartState _ (TWFP n t)))
- - = unseal2 handlePair <$>
- - let xs = unseal getPairs (flattenOne t)
- - in if length xs > n && n >= 0 then Just (xs!!n) else Nothing
- -
- -commutePairFromTree :: (FromPrim p, Merge p)
- - => (forall wY wZ . (p :> p) wY wZ -> t)
- - -> Sealed (WithStartState model (Tree (PrimOf p)))
- - -> Maybe t
- -commutePairFromTree handlePair (Sealed (WithStartState _ t))
- - = unseal2 handlePair <$>
- - let xs = unseal getPairs (flattenOne t)
- - in if null xs then Nothing else Just (last xs)
- -
- -commuteTripleFromTree :: (FromPrim p, Merge p)
- - => (forall wY wZ . (p :> p :> p) wY wZ -> t)
- - -> Sealed (WithStartState model (Tree (PrimOf p)))
- - -> Maybe t
- -commuteTripleFromTree handle (Sealed (WithStartState _ t))
- - = unseal2 handle <$>
- - case flattenOne t of
- - Sealed ps ->
- - let xs = getTriples ps
- - in if null xs
- - then Nothing
- - else Just (last xs)
- -
- -mergePairFromCommutePair :: Commute p
- - => (forall wY wZ . (p :\/: p) wY wZ -> t)
- - -> (forall wY wZ . (p :> p) wY wZ -> t)
- -mergePairFromCommutePair handlePair (a :> b)
- - = case commute (a :> b) of
- - Just (b' :> _) -> handlePair (a :\/: b')
- - Nothing -> handlePair (b :\/: b)
- -
- --- impredicativity problems mean we can't use (.) in the definitions below
- -
- -mergePairFromTWFP :: (FromPrim p, Commute p, Merge p)
- - => (forall wY wZ . (p :\/: p) wY wZ -> t)
- - -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
- - -> Maybe t
- -mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)
- -
- -mergePairFromTree :: (FromPrim p, Commute p, Merge p)
- - => (forall wY wZ . (p :\/: p) wY wZ -> t)
- - -> Sealed (WithStartState model (Tree (PrimOf p)))
- - -> Maybe t
- -mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)
- -
- -patchFromCommutePair :: (forall wY wZ . p wY wZ -> t)
- - -> (forall wY wZ . (p :> p) wY wZ -> t)
- -patchFromCommutePair handle (_ :> b) = handle b
- -
- -patchFromTree :: (FromPrim p, Merge p)
- - => (forall wY wZ . p wY wZ -> t)
- - -> Sealed (WithStartState model (Tree (PrimOf p)))
- - -> Maybe t
- -patchFromTree x = commutePairFromTree (patchFromCommutePair x)
- -
- -
- -instance Show2 p => Show (TreeWithFlattenPos p wX) where
- - showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .
- - showsPrec (appPrec + 1) n . showString " " .
- - showsPrec1 (appPrec + 1) t
- -
- -getPairs :: FL p wX wY -> [Sealed2 (p :> p)]
- -getPairs NilFL = []
- -getPairs (_:>:NilFL) = []
- -getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)
- -
- -getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]
- -getTriples NilFL = []
- -getTriples (_:>:NilFL) = []
- -getTriples (_:>:_:>:NilFL) = []
- -getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)
- -
- -instance ( ArbitraryPrim prim
- - , RepoModel (ModelOf prim)
- - , model ~ ModelOf prim
- - , ArbitraryState prim
- - ) =>
- - Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where
- - arbitrary = do
- - Sealed (WithStartState rm t) <- arbitrary
- - case numPairs t of
- - 0 -> return $ Sealed $ WithStartState rm $ TWFP 0 NilTree
- - num -> do
- - n <- choose (0, num - 1)
- - return $ Sealed $ WithStartState rm $ TWFP n t
- -
addfile ./harness/Darcs/Test/Patch/Arbitrary/PatchTree.hs
hunk ./harness/Darcs/Test/Patch/Arbitrary/PatchTree.hs 1
+{-# LANGUAGE ViewPatterns #-}
+module Darcs.Test.Patch.Arbitrary.PatchTree
+ ( Tree(..)
+ , TreeWithFlattenPos(..)
+ , G2(..)
+ , flattenOne
+ , flattenTree
+ , mapTree
+ , commutePairFromTree
+ , mergePairFromTree
+ , commuteTripleFromTree
+ , mergePairFromCommutePair
+ , commutePairFromTWFP
+ , mergePairFromTWFP
+ , getPairs
+ , getTriples
+ , patchFromTree
+ , canonizeTree
+ ) where
+
+import Darcs.Prelude
+
+import Test.QuickCheck
+
+import Darcs.Test.Patch.Arbitrary.Generic
+import Darcs.Test.Patch.WithState
+import Darcs.Test.Patch.RepoModel
+import Darcs.Test.Util.QuickCheck ( bSized )
+
+import Darcs.Patch.Witnesses.Sealed
+import Darcs.Patch.Witnesses.Eq
+import Darcs.Patch.Witnesses.Unsafe
+import Darcs.Patch.Witnesses.Ordered
+import Darcs.Patch.Merge ( Merge(..) )
+import Darcs.Patch.Commute ( Commute(..) )
+import Darcs.Patch.FromPrim ( FromPrim(..), PrimOf )
+import Darcs.Patch.Witnesses.Show
+
+-- | A 'Tree' of patches 'p' starting at state 'wX' simulating
+-- several branches of a repo. The end states of the branches
+-- may of course differ.
+data Tree p wX where
+ NilTree :: Tree p wX
+ SeqTree :: p wX wY -> Tree p wY -> Tree p wX
+ ParTree :: Tree p wX -> Tree p wX -> Tree p wX
+
+mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX
+mapTree _ NilTree = NilTree
+mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)
+mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)
+
+instance Show2 p => Show (Tree p wX) where
+ showsPrec _ NilTree = showString "NilTree"
+ showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .
+ showsPrec2 (appPrec + 1) a . showString " " .
+ showsPrec (appPrec + 1) t
+ showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .
+ showsPrec (appPrec + 1) t1 . showString " " .
+ showsPrec (appPrec + 1) t2
+
+instance Show2 p => Show1 (Tree p)
+
+instance Show2 p => Show1 (TreeWithFlattenPos p)
+
+-- | The number of patches in a 'Tree'. This is the (common) length of all
+-- elements of 'flattenTree'.
+sizeTree :: Tree p wX -> Int
+sizeTree NilTree = 0
+sizeTree (SeqTree _ t) = 1 + sizeTree t
+sizeTree (ParTree t1 t2) = sizeTree t1 + sizeTree t2
+
+-- | The number of successive pairs in a flattened 'Tree'.
+numPairs :: Tree p wX -> Int
+numPairs t =
+ case sizeTree t of
+ 0 -> 0
+ s -> s - 1
+
+-- | The number of successive triples in a flattened 'Tree'.
+numTriples :: Tree p wX -> Int
+numTriples t =
+ case sizeTree t of
+ 0 -> 0
+ 1 -> 0
+ s -> s - 2
+
+newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }
+
+-- | All possible ways that the several branches of a 'Tree' can be
+-- merged into a linear sequence.
+flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)
+flattenTree NilTree = seal $ G2 $ return NilFL
+flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t
+flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2)) =
+ seal $
+ G2 $ do
+ ps1 <- unG2 gpss1
+ ps2 <- unG2 gpss2
+ ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)
+ -- We can't prove that the existential type in the result
+ -- of merge will be the same for each pair of ps1 and ps2.
+ map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']
+
+-- | Generate a tree of patches, bounded by depth.
+arbitraryTree :: ArbitraryState p => ModelOf p wX -> Int -> Gen (Tree p wX)
+arbitraryTree rm depth
+ | depth == 0 = return NilTree
+ -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.
+ -- For the purpose of this module empty trees are useless, but even when
+ -- NilTree case is omitted there is still a small percentage of empty trees
+ -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.
+ | otherwise =
+ frequency
+ [ ( 1
+ , do Sealed (WithEndState p rm') <- arbitraryState rm
+ t <- arbitraryTree rm' (depth - 1)
+ return (SeqTree p t))
+ , ( 3
+ , do t1 <- arbitraryTree rm (depth - 1)
+ t2 <- arbitraryTree rm (depth - 1)
+ return (ParTree t1 t2))
+ ]
+
+-- | Canonize a 'Tree', removing any dead branches.
+canonizeTree :: NullPatch p => Tree p wX -> Tree p wX
+canonizeTree NilTree = NilTree
+canonizeTree (ParTree t1 t2)
+ | NilTree <- canonizeTree t1 = canonizeTree t2
+ | NilTree <- canonizeTree t2 = canonizeTree t1
+ | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)
+canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t
+ | otherwise = SeqTree p (canonizeTree t)
+
+
+-- | Generate a patch to a certain state.
+class ArbitraryStateIn s p where
+ arbitraryStateIn :: s wX -> Gen (p wX)
+
+instance (ArbitraryState p, s ~ ModelOf p) => ArbitraryStateIn s (Tree p) where
+ -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).
+ -- Note if we don't put a non-zero lower bound the first generated trees will
+ -- always have depth 0.
+ -- The minimum size of 3 means that we have a reasonable probability that the
+ -- Tree has at least one triple.
+ arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth
+
+instance ( RepoModel model
+ , ArbitraryPrim prim
+ , model ~ ModelOf prim
+ , ArbitraryState prim
+ ) =>
+ Arbitrary (Sealed (WithStartState model (Tree prim))) where
+ arbitrary = do
+ repo <- aSmallRepo
+ Sealed . WithStartState repo <$>
+ (canonizeTree <$> arbitraryStateIn repo) `suchThat` (\t -> numTriples t >= 1)
+
+flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)
+flattenOne NilTree = seal NilFL
+flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromAnonymousPrim p :>: ps)
+flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =
+ case merge (ps1 :\/: ps2) of
+ ps2' :/\: _ -> seal (ps1 +>+ ps2')
+
+-- | A 'Tree' together with some number that is no greater than
+-- the number of pairs in the 'Tree'.
+data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)
+
+commutePairFromTWFP :: (FromPrim p, Merge p)
+ => (forall wY wZ . (p :> p) wY wZ -> t)
+ -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
+ -> Maybe t
+commutePairFromTWFP handlePair (Sealed (WithStartState _ (TWFP n t)))
+ = unseal2 handlePair <$>
+ let xs = unseal getPairs (flattenOne t)
+ in if length xs > n && n >= 0 then Just (xs!!n) else Nothing
+
+commutePairFromTree :: (FromPrim p, Merge p)
+ => (forall wY wZ . (p :> p) wY wZ -> t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+commutePairFromTree handlePair (Sealed (WithStartState _ t))
+ = unseal2 handlePair <$>
+ let xs = unseal getPairs (flattenOne t)
+ in if null xs then Nothing else Just (last xs)
+
+commuteTripleFromTree :: (FromPrim p, Merge p)
+ => (forall wY wZ . (p :> p :> p) wY wZ -> t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+commuteTripleFromTree handle (Sealed (WithStartState _ t))
+ = unseal2 handle <$>
+ case flattenOne t of
+ Sealed ps ->
+ let xs = getTriples ps
+ in if null xs
+ then Nothing
+ else Just (last xs)
+
+mergePairFromCommutePair :: Commute p
+ => (forall wY wZ . (p :\/: p) wY wZ -> t)
+ -> (forall wY wZ . (p :> p) wY wZ -> t)
+mergePairFromCommutePair handlePair (a :> b)
+ = case commute (a :> b) of
+ Just (b' :> _) -> handlePair (a :\/: b')
+ Nothing -> handlePair (b :\/: b)
+
+-- impredicativity problems mean we can't use (.) in the definitions below
+
+mergePairFromTWFP :: (FromPrim p, Commute p, Merge p)
+ => (forall wY wZ . (p :\/: p) wY wZ -> t)
+ -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))
+ -> Maybe t
+mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)
+
+mergePairFromTree :: (FromPrim p, Commute p, Merge p)
+ => (forall wY wZ . (p :\/: p) wY wZ -> t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)
+
+patchFromCommutePair :: (forall wY wZ . p wY wZ -> t)
+ -> (forall wY wZ . (p :> p) wY wZ -> t)
+patchFromCommutePair handle (_ :> b) = handle b
+
+patchFromTree :: (FromPrim p, Merge p)
+ => (forall wY wZ . p wY wZ -> t)
+ -> Sealed (WithStartState model (Tree (PrimOf p)))
+ -> Maybe t
+patchFromTree x = commutePairFromTree (patchFromCommutePair x)
+
+
+instance Show2 p => Show (TreeWithFlattenPos p wX) where
+ showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .
+ showsPrec (appPrec + 1) n . showString " " .
+ showsPrec1 (appPrec + 1) t
+
+getPairs :: FL p wX wY -> [Sealed2 (p :> p)]
+getPairs NilFL = []
+getPairs (_:>:NilFL) = []
+getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)
+
+getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]
+getTriples NilFL = []
+getTriples (_:>:NilFL) = []
+getTriples (_:>:_:>:NilFL) = []
+getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)
+
+instance ( ArbitraryPrim prim
+ , RepoModel (ModelOf prim)
+ , model ~ ModelOf prim
+ , ArbitraryState prim
+ ) =>
+ Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where
+ arbitrary = do
+ Sealed (WithStartState rm t) <- arbitrary
+ case numPairs t of
+ 0 -> return $ Sealed $ WithStartState rm $ TWFP 0 NilTree
+ num -> do
+ n <- choose (0, num - 1)
+ return $ Sealed $ WithStartState rm $ TWFP n t
hunk ./harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 60
- -import Darcs.Test.Patch.Arbitrary.Generic
+import Darcs.Test.Patch.Arbitrary.PatchTree
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 46
- -import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne, MightBeEmptyHunk(..), MightHaveDuplicate(..), TestablePrim )
+import Darcs.Test.Patch.Arbitrary.Generic
+ ( MightBeEmptyHunk(..)
+ , MightHaveDuplicate(..)
+ , TestablePrim
+ )
+import Darcs.Test.Patch.Arbitrary.PatchTree ( Tree, flattenOne )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 15
- - ( Tree, flattenTree, G2(..), mapTree, MergeableSequence, mergeableSequenceToRL )
+ ( MergeableSequence, mergeableSequenceToRL )
+import Darcs.Test.Patch.Arbitrary.PatchTree
+ ( Tree, flattenTree, G2(..), mapTree )
hunk ./harness/Darcs/Test/Patch/WSub.hs 21
- -import qualified Darcs.Test.Patch.Arbitrary.Generic as W
+import qualified Darcs.Test.Patch.Arbitrary.PatchTree as W
hunk ./harness/Darcs/Test/Patch/WithState.hs 48
+-- | This is only used for the legacy 'Tree' based test generator, where the
+-- @p@ parameter gets instantiated to @'Tree' p@ (which has no definite end
+-- state).
hunk ./harness/Darcs/Test/Patch.hs 61
+import Darcs.Test.Patch.Arbitrary.PatchTree
[tests: GHC 8.6 requires a couple of UndecidableInstances
Ganesh Sittampalam <ganesh at earth.li>**20200219223603
Ignore-this: 561e50b5935e3fb970d04baa3bcb34bf
] hunk ./harness/Darcs/Test/Patch.hs 18
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/PatchTree.hs 1
+{-# LANGUAGE UndecidableInstances #-}
[add comments about why UndecidableInstances is needed
Ganesh Sittampalam <ganesh at earth.li>**20200220173409
Ignore-this: 18951fc0b1d07f5099351cf6ea5da4c5
] hunk ./harness/Darcs/Test/Patch.hs 18
+-- UndecidableInstances was added because GHC 8.6 needed it
+-- even though GHC 8.2 didn't
hunk ./harness/Darcs/Test/Patch/Arbitrary/PatchTree.hs 1
+-- UndecidableInstances was added because GHC 8.6 needed it
+-- even though GHC 8.2 didn't
[tests: always use prim patches for generating/shrinking
Ganesh Sittampalam <ganesh at earth.li>**20200223105834
Ignore-this: 78228df56a64bd01314bcd82a4aa4270
We already didn't try to generate conflicted patches, and
even shrinking unconflicted patches is actually unsound if
there might be a conflict later in a sequence.
Instead of needing partial functions on repo patches, it's
better to express this invariant in the types by only storing
prim patches, and generating the repo patches on the fly
when actually using the test cases.
] hunk ./harness/Darcs/Test/Patch.hs 220
+ , Shrinkable prim
hunk ./harness/Darcs/Test/Patch.hs 248
+ , Shrinkable prim
hunk ./harness/Darcs/Test/Patch.hs 267
- - , Shrinkable p
hunk ./harness/Darcs/Test/Patch.hs 269
- - , ArbitraryState p
hunk ./harness/Darcs/Test/Patch.hs 270
- - , PropagateShrink (PrimOf p) p
+ , PrimBased p
hunk ./harness/Darcs/Test/Patch.hs 296
- - , ArbitraryState p
- - , Shrinkable p
hunk ./harness/Darcs/Test/Patch.hs 297
- - , PropagateShrink (PrimOf p) p
hunk ./harness/Darcs/Test/Patch.hs 300
+ , PrimBased p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 6
+ , PrimBased(..)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 104
+ , Shrinkable prim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 152
+-- |Given a patch type that contains mergeable patches, such as
+-- @RepoPatchV1 prim@ or @Named (RepoPatchV1 prim)@, construct the
+-- equivalent conflict-free types, e.g. @prim@ / @Named prim@ respectively.
+class ( Effect p, Show2 (OnlyPrim p), ArbitraryState (OnlyPrim p)
+ , Shrinkable (OnlyPrim p), PropagateShrink (PrimOf p) (OnlyPrim p)
+ , ModelOf p ~ ModelOf (OnlyPrim p)
+ )
+ => PrimBased p where
+ type OnlyPrim p :: * -> * -> *
+ primEffect :: OnlyPrim p wX wY -> FL (PrimOf p) wX wY
+ liftFromPrim :: OnlyPrim p wX wY -> p wX wY
+
+instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (FL p) where
+ type OnlyPrim (FL p) = FL (OnlyPrim p)
+ primEffect = concatFL . mapFL_FL (primEffect @p)
+ liftFromPrim = mapFL_FL liftFromPrim
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 175
+-- Note that although MergeableSequence is parameterised on a patch type @p@
+-- that needs to support merging, it only explicitly contains primitive
+-- patches. The merged patches are constructed on-the-fly when the structure
+-- is used. It's necessary to fix the structure to a specific mergeable patch
+-- type because otherwise the merged patches could vary, invalidating the
+-- context of conflict resolution patches like @z at .
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 185
- - -> p wY wZ
+ -> OnlyPrim p wY wZ
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 195
- -instance (Merge p, Effect p) => Effect (MergeableSequence p) where
+instance (Merge p, PrimBased p) => Effect (MergeableSequence p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 197
- - effect (SeqMS ps p) = effect ps +>+ effect p
+ effect (SeqMS ps p) = effect ps +>+ primEffect @p p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 206
- - ( PropagateShrink prim p
+ ( PropagateShrink prim (OnlyPrim p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 209
+ , PrimBased p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 274
- -instance Show2 p => Show (MergeableSequence p wX wY) where
+instance (Show2 p, PrimBased p) => Show (MergeableSequence p wX wY) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 281
- -instance Show2 p => Show1 (MergeableSequence p wX)
- -instance Show2 p => Show2 (MergeableSequence p)
+instance (Show2 p, PrimBased p) => Show1 (MergeableSequence p wX)
+instance (Show2 p, PrimBased p) => Show2 (MergeableSequence p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 294
- -instance Shrinkable p => Shrinkable (MergeableSequence p) where
+instance Shrinkable (OnlyPrim p) => Shrinkable (MergeableSequence p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 324
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 328
- -mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: p
+mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: liftFromPrim p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 343
- - , Merge p
+ , Merge p, PrimBased p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 346
- - => (forall wA . model wA -> Gen (Sealed (WithEndState model (p wA))))
+ => (forall wA . model wA -> Gen (Sealed (WithEndState model (OnlyPrim p wA))))
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 377
+ , model ~ ModelOf (OnlyPrim p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 380
- - , ArbitraryState p
+ , PrimBased p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 9
+import Darcs.Test.Patch.Arbitrary.Generic
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 16
- -import Darcs.Patch.FromPrim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 23
- -type instance ModelOf (Named p) = ModelOf (PrimOf p)
- -
- -instance (FromPrim p, ArbitraryState (PrimOf p))
- - => ArbitraryState (Named p) where
+type instance ModelOf (Named prim) = ModelOf prim
+
+instance ArbitraryState prim => ArbitraryState (Named prim) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 28
- - -- we must first construct an arbitrary Named from unconflicted
- - -- patches - we can later turn it into a conflicted patch by
- - -- merging, but it's an important invariant of darcs that any
- - -- Named can be commuted back to an unconflicted variant.
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 29
- - return $ Sealed $ WithEndState (infopatch info prims) rm'
+ return $ Sealed $ WithEndState (NamedP info [] prims) rm'
hunk ./harness/Darcs/Test/Patch/Arbitrary/Named.hs 47
+instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (Named p) where
+ type OnlyPrim (Named p) = Named (OnlyPrim p)
+
+ primEffect (NamedP _ _ ps) = primEffect @(FL p) ps
+ liftFromPrim (NamedP pi deps ps) = NamedP pi deps (liftFromPrim ps)
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 13
+import Darcs.Test.Patch.Arbitrary.Shrink
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 33
+instance Shrinkable prim => Shrinkable (PrimWithName n prim) where
+ shrinkInternally (PrimWithName n p) = PrimWithName n <$> shrinkInternally p
+ shrinkAtEnd (PrimWithName n p) = mapSeal (PrimWithName n) <$> shrinkAtEnd p
+ shrinkAtStart (PrimWithName n p) = mapFlipped (PrimWithName n) <$> shrinkAtStart p
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 8
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 34
+-- TODO add some useful shrinking, at least to
+-- shrinkAtEnd/shrinkAtStart
+instance Shrinkable Prim where
+ shrinkInternally _ = []
+ shrinkAtEnd _ = []
+ shrinkAtStart _ = []
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 17
+import Darcs.Test.Patch.Arbitrary.Shrink
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs 73
+-- TODO add some useful shrinking, at least to
+-- shrinkAtEnd/shrinkAtStart
+instance Shrinkable Prim.Prim where
+ shrinkInternally _ = []
+ shrinkAtEnd _ = []
+ shrinkAtStart _ = []
+
+deriving instance Shrinkable V1.Prim
+deriving instance Shrinkable V2.Prim
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 17
- - ( mergeableSequenceToRL, MergeableSequence(..), ArbitraryPrim(..) )
+ ( mergeableSequenceToRL, MergeableSequence(..), ArbitraryPrim(..), PrimBased )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 34
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 43
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 52
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 61
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 72
- - :: Merge p
+ :: (Merge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 18
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 34
- - , commute
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 40
- -import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 50
- -import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate )
- -import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate, ArbitraryPrim,PrimBased(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 52
- -import Darcs.Test.Patch.WithState
- - ( ArbitraryState(..)
- - , PropagateShrink(..)
- - , WithEndState(..)
- - )
+import Darcs.Test.Patch.WithState ( PropagateShrink(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 123
- -instance Shrinkable (RepoPatchV1 prim) where
- - shrinkInternally _ = []
- - shrinkAtStart _ = []
- - shrinkAtEnd _ = []
- -
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 125
- -instance ArbitraryState prim => ArbitraryState (RepoPatchV1 prim) where
- - arbitraryState rStart = do
- - Sealed (WithEndState p rEnd) <- arbitraryState rStart
- - return (Sealed (WithEndState (PP p) rEnd))
- -
- -instance
- - ( PrimPatch prim, PropagateShrink prim prim
- - )
- - => PropagateShrink prim (RepoPatchV1 prim) where
- - propagateShrink (prim1 :> PP prim2) = do
- - mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
- - return $ mapMB_MB PP mprim2' :> mprim1'
- - -- Actually shrinking conflicts is hard to do correctly,
- - -- because the correctness of the conflict depends on the
- - -- patch the conflict is with which isn't visible here,
- - -- but we can try to commute past them.
- - propagateShrink (prim1 :> p2) = do
- - p2' :> PP prim1' <- commute (PP prim1 :> p2)
- - return $ Just2 p2' :> Just2 prim1'
+instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV1 prim) where
+ type OnlyPrim (RepoPatchV1 prim) = prim
+ primEffect prim = prim :>: NilFL
+ liftFromPrim = PP
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 1
+{-# LANGUAGE UndecidableInstances #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 4
- -import Darcs.Prelude
- -
- -import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..) )
- -import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 6
- -import Darcs.Test.Patch.WithState ( PropagateShrink(..), ArbitraryState(..), WithEndState(..) )
- -import Darcs.Patch.Commute ( commute )
+import Darcs.Test.Patch.WithState ( PropagateShrink )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 10
- -import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 11
- -import Darcs.Patch.Witnesses.Sealed
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 17
- -instance ArbitraryState prim => ArbitraryState (RepoPatchV2 prim) where
- - arbitraryState rStart = do
- - Sealed (WithEndState p rEnd) <- arbitraryState rStart
- - return (Sealed (WithEndState (Normal p) rEnd))
- -
- -instance Shrinkable (RepoPatchV2 prim) where
- - shrinkInternally _ = []
- - shrinkAtStart _ = []
- - shrinkAtEnd _ = []
- -
- -instance (PrimPatch prim, PropagateShrink prim prim)
- - => PropagateShrink prim (RepoPatchV2 prim) where
- -
- - propagateShrink (prim1 :> Normal prim2) = do
- - mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
- - return $ mapMB_MB Normal mprim2' :> mprim1'
- - -- Actually shrinking conflicts is hard to do correctly,
- - -- because the correctness of the conflict depends on the
- - -- patch the conflict is with which isn't visible here,
- - -- but we can try to commute past them.
- - propagateShrink (prim1 :> p2) = do
- - p2' :> Normal prim1' <- commute (Normal prim1 :> p2)
- - return $ Just2 p2' :> Just2 prim1'
+instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV2 prim) where
+ type OnlyPrim (RepoPatchV2 prim) = prim
+ primEffect = (:>: NilFL)
+ liftFromPrim = Normal
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 1
- -{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 6
- -import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..) )
+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 8
- -import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 9
- -import Darcs.Test.Patch.WithState ( PropagateShrink(..), ArbitraryState(..), WithEndState(..) )
+import Darcs.Test.Patch.WithState ( PropagateShrink )
+
+import Darcs.Patch.Prim.Class
+import Darcs.Patch.Prim.Named
+import Darcs.Patch.Prim.WithName
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 17
- -import Darcs.Patch.Witnesses.Maybe
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 18
- -import Darcs.Patch.Witnesses.Sealed
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 24
- -instance ArbitraryState prim => ArbitraryState (RepoPatchV3 prim) where
- - arbitraryState rStart = do
- - Sealed (WithEndState p rEnd) <- arbitraryState rStart
- - return (Sealed (WithEndState (V3.Prim p) rEnd))
- -
- -instance Shrinkable (RepoPatchV3 prim) where
- - shrinkInternally _ = []
- - shrinkAtStart _ = []
- - shrinkAtEnd _ = []
- -
- -instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (RepoPatchV3 prim2) where
- - propagateShrink (prim1 :> V3.Prim prim2) = do
- - mprim2' :> mprim1' <- propagateShrink (prim1 :> prim2)
- - return $ mapMB_MB V3.Prim mprim2' :> mprim1'
- - -- don't try to shrink conflicts, it's too hard to do correctly
- - -- the general strategy for test cases is to define them with unconflicted patches
- - -- then use merge to generate conflicts
- - propagateShrink _ = Nothing
+instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV3 prim) where
+ type OnlyPrim (RepoPatchV3 prim) = NamedPrim prim
+ primEffect p = wnPatch p :>: NilFL
+ liftFromPrim = V3.Prim
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 15
- - ( MergeableSequence, mergeableSequenceToRL )
+ ( MergeableSequence, mergeableSequenceToRL, PrimBased )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 79
+ , PrimBased p
[tests: introduce infrastructure for merge checking
Ganesh Sittampalam <ganesh at earth.li>**20200223120659
Ignore-this: 5e3d0ad0594f8da6873533685ce7d30d
Because V1 and V2 patches are known to be buggy, we
sometimes need to exclude buggy merges when using them
to test other properties.
] hunk ./darcs.cabal 592
+ Darcs.Test.Patch.Merge.Checked
hunk ./harness/Darcs/Test/Patch.hs 73
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )
hunk ./harness/Darcs/Test/Patch.hs 270
+ , CheckedMerge p
hunk ./harness/Darcs/Test/Patch.hs 300
+ , CheckedMerge p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 27
+import Darcs.Test.Patch.Merge.Checked
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 39
- -import Darcs.Patch.Merge ( Merge(..) )
+import Darcs.Patch.Merge ( Merge(..), mergerFLFL )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 145
+-- | A wrapper around 'merge' for FL that checks each individual merge,
+-- and also returns a more strongly typed witness than the usual existential.
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 148
- - :: Merge p
- - => (p :\/: p) wA wB
- - -> (p wA (Merged wA wB), p wB (Merged wA wB))
+ :: CheckedMerge p
+ => (FL p :\/: FL p) wA wB
+ -> (FL p wA (Merged wA wB), FL p wB (Merged wA wB))
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 152
- - case merge (p :\/: q) of
+ case mergerFLFL (checkedMerger merge) (p :\/: q) of
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 198
- -instance (Merge p, PrimBased p) => Effect (MergeableSequence p) where
+instance (CheckedMerge p, PrimBased p) => Effect (MergeableSequence p) where
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 210
- - , Merge p, Effect p, PrimOf p ~ prim
+ , CheckedMerge p, Effect p, PrimOf p ~ prim
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 327
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 345
- - :: ( RepoModel model
- - , Merge p, PrimBased p
+ :: forall model p wX
+ . ( RepoModel model
+ , CheckedMerge p
+ , PrimBased p
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 370
- - case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of
- - (ps2', _) ->
- - case repoApply rm (ps1 +>>+ ps2') of
- - OK rm' -> return $ Sealed $
- - WithEndState (parMS ms1 ms2) rm'
- - Failed msg -> error msg
+ case validateMerge @p (typedMerge (reverseRL ps1 :\/:reverseRL ps2)) of
+ Nothing -> go rm depth
+ Just (ps2', _) ->
+ case repoApply rm (ps1 +>>+ ps2') of
+ OK rm' -> return $ Sealed $ WithEndState (parMS ms1 ms2) rm'
+ Failed msg -> error msg
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 384
- - , Merge p
+ , CheckedMerge p
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 18
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 23
- -import Darcs.Patch.Merge ( Merge )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 34
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 43
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 52
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 61
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 72
- - :: (Merge p, PrimBased p)
+ :: (CheckedMerge p, PrimBased p)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 25
+import Control.Exception ( try, evaluate, SomeException )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 27
+import System.IO.Unsafe
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 53
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 65
+instance PrimPatch prim => CheckedMerge (RepoPatchV1 prim) where
+ validateMerge v =
+ case unsafePerformIO (try (evaluate v)) of
+ Left (_ :: SomeException) -> Nothing
+ Right x -> Just x
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 4
+import Darcs.Prelude
+
+import Control.Exception
+import System.IO.Unsafe
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 10
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 23
+instance PrimPatch prim => CheckedMerge (RepoPatchV2 prim) where
+ validateMerge v =
+ case unsafePerformIO (try (evaluate v)) of
+ Left (_ :: SomeException) -> Nothing
+ Right x -> Just x
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 8
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 25
+instance PrimPatch prim => CheckedMerge (RepoPatchV3 prim)
+
adddir ./harness/Darcs/Test/Patch/Merge
addfile ./harness/Darcs/Test/Patch/Merge/Checked.hs
hunk ./harness/Darcs/Test/Patch/Merge/Checked.hs 1
+module Darcs.Test.Patch.Merge.Checked
+ ( CheckedMerge(..), checkedMerger
+ ) where
+
+import Darcs.Prelude
+
+import Darcs.Patch.Commute
+import Darcs.Patch.CommuteFn
+import Darcs.Patch.Effect
+import Darcs.Patch.FromPrim ( PrimOf )
+import Darcs.Patch.Invert
+import Darcs.Patch.Merge
+import Darcs.Patch.Named
+
+import Darcs.Patch.Witnesses.Eq
+import Darcs.Patch.Witnesses.Ordered
+ ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), (:>)(..)
+ )
+
+import GHC.Stack
+
+class
+ (Merge p, Effect p, Eq2 p, Eq2 (PrimOf p), Commute p, Commute (PrimOf p), Invert (PrimOf p))
+ => CheckedMerge p
+ where
+
+ -- |V1 and V2 merges can produce invalid patches. We use 'checkedMerger' to
+ -- validate all merges and fail if there is a problem. When generating tests
+ -- we might want to continue after a failure instead of reporting it, so we
+ -- can test some other property on all *valid* V1/V2 patches.
+ --
+ -- This hook allows V1/V2 patches to catch such errors using unsafePerformIO.
+ -- Type type is generic to allow arbitrary structures containing mergers to
+ -- be checked - e.g. a tuple of two merge results.
+ --
+ -- There are three reasonable ways of implementing validateMerge. The default
+ -- is 'Just' which means no validation.
+ --
+ -- For repo patch types that might have errors, use unsafePerformIO with try and
+ -- evaluate to catch errors and convert them into Nothing.
+ --
+ -- Finally for compound patch types like Named, FL etc, just delegate to
+ -- validateMerge of the underlying patch type.
+ --
+ -- We could do all this in the Maybe monad right through, but that would
+ -- pollute all the generic code with a monad that is only needed because of bugs
+ -- in "older" patch implementations
+ validateMerge :: a -> Maybe a
+ validateMerge = Just
+
+instance CheckedMerge p => CheckedMerge (Named p) where
+ validateMerge = validateMerge @p
+
+instance CheckedMerge p => CheckedMerge (FL p) where
+ validateMerge = validateMerge @p
+
+checkedMerger :: (HasCallStack, CheckedMerge p) => MergeFn p p -> MergeFn p p
+checkedMerger fn pair = let res = fn pair in checkMerge pair res `seq` res
+
+checkMerge
+ :: (HasCallStack, CheckedMerge p)
+ => (p :\/: p) wX wY
+ -> (p :/\: p) wX wY
+ -> ()
+checkMerge (p :\/: q) (q' :/\: p')
+ -- TODO this check doesn't work at the moment - try to enable it and see if it makes
+ -- sense to keep or not.
+ | False, NotEq <- (p :>: q' :>: NilFL) =\/= (q :>: p' :>: NilFL) =
+ error "internal error: merge didn't produce equivalent sequences"
+ | NotEq <- squashes (effect p +>+ effect q' +>+ invert (effect q +>+ effect p')) =
+ error "internal error: merge didn't produce equivalent effects"
+ | otherwise = ()
+
+squashCons :: (Commute p, Eq2 p, Invert p) => p wX wY -> FL p wY wZ -> FL p wX wZ
+squashCons p NilFL = p :>: NilFL
+squashCons p (q :>: qs)
+ | IsEq <- invert p =\/= q = qs
+ | Just (q' :> p') <- commute (p :> q) = q' :>: squashCons p' qs
+ | otherwise = p :>: q :>: qs
+
+squash :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> FL p wX wY
+squash NilFL = NilFL
+squash (p :>: ps) = squashCons p (squash ps)
+
+squashes :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> EqCheck wX wY
+squashes ps =
+ case squash ps of
+ NilFL -> IsEq
+ _ -> NotEq
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 18
+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 80
+ , CheckedMerge p
[tests: export V1Model(..)
Ganesh Sittampalam <ganesh at earth.li>**20200223184420
Ignore-this: dab4d5c89e2514464a66ac7aea6f8948
] hunk ./harness/Darcs/Test/Patch/V1Model.hs 3
- - ( V1Model, repoTree
- - , RepoItem, File, Dir, Content
+ ( V1Model(..)
+ , RepoItem(..), File, Dir, Content
[harness: remove propIsMergeable
Ben Franksen <ben.franksen at online.de>**20200216192013
Ignore-this: 55ab3a3b85186f9fef3f92765ee7d5d72c6a87250872f34a015ec70d8d6b02b3f97bc904f50844be
This test is completely redundant. It merely checks whether flattening a
Tree of patches crashes. We test this much more thoroughly with the other
merge tests.
] hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 36
- - , propIsMergeable
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 40
- -import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, rejected,
- - maybeFailed )
- -import Darcs.Test.Patch.RepoModel ( RepoModel, RepoState, repoApply, eqModel, showModel
- - , maybeFail, ModelOf )
- -import Darcs.Test.Patch.WithState ( WithState(..), WithStartState(..) )
+import Darcs.Test.Patch.RepoModel
+ ( ModelOf
+ , RepoModel
+ , RepoState
+ , eqModel
+ , maybeFail
+ , repoApply
+ , showModel
+ )
+import Darcs.Test.Util.TestResult
+ ( TestResult
+ , failed
+ , maybeFailed
+ , rejected
+ , succeeded
+ )
+import Darcs.Test.Patch.WithState ( WithState(..) )
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 62
- -import Darcs.Test.Patch.Arbitrary.PatchTree ( Tree, flattenOne )
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 70
- -import Darcs.Patch.FromPrim ( PrimOf, FromPrim )
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 78
- -import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, mapFL )
- -import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 )
+import Darcs.Patch.Witnesses.Ordered
+ ( (:/\:)(..)
+ , (:>)(..)
+ , (:\/:)(..)
+ , FL(..)
+ , eqFL
+ , mapFL
+ )
+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 90
- -propIsMergeable :: forall model p wX . (FromPrim p, Merge p)
- - => Sealed (WithStartState model (Tree (PrimOf p)))
- - -> Maybe (Tree p wX)
- -propIsMergeable (Sealed (WithStartState _ t))
- - = case flattenOne t of
- - Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)
- - in case lengthFL ps of
- - _ -> Nothing
- -
hunk ./harness/Darcs/Test/Patch.hs 26
- -import Data.Maybe( isNothing )
hunk ./harness/Darcs/Test/Patch.hs 75
- - ( WithState, WithStartState
- - , ArbitraryState
- - , PropagateShrink, ShrinkModel
- - , makeS2Gen, makeWS2Gen
- - , arbitraryTriple, wesPatch
- - )
+ ( ArbitraryState
+ , PropagateShrink
+ , ShrinkModel
+ , WithState
+ , arbitraryTriple
+ , makeS2Gen
+ , makeWS2Gen
+ , wesPatch
+ )
hunk ./harness/Darcs/Test/Patch.hs 282
- - , testProperty "we can do merges"
- - (isNothing . (PropG.propIsMergeable ::
- - Sealed (WithStartState (ModelOf p) (Tree (PrimOf p)))
- - -> Maybe (Tree p wA)))
[tests: move patch properties into D.T.P.P.Generic
Ganesh Sittampalam <ganesh at earth.li>**20200223184806
Ignore-this: 40dcda6d9c4cad8a15e449a53a9f1aad
This means they can be used from D.T.P.RepoPatchV1
] hunk ./harness/Darcs/Test/Patch.hs 91
+import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty )
hunk ./harness/Darcs/Test/Patch.hs 264
- -type PatchProperty p = forall wA wB. p wA wB -> TestResult
- --- type PairProperty p = forall wA wB. (p :> p) wA wB -> TestResult
- -type MergeProperty p = forall wA wB. (FL p :\/: FL p) wA wB -> TestResult
- -type SequenceProperty p = forall wA wB. RL p wA wB -> TestResult
- -
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 36
+ , PatchProperty
+ , MergeProperty
+ , SequenceProperty
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 86
+ , RL(..)
hunk ./harness/Darcs/Test/Patch/Properties/Generic.hs 94
+type PatchProperty p = forall wA wB. p wA wB -> TestResult
+-- type PairProperty p = forall wA wB. (p :> p) wA wB -> TestResult
+type MergeProperty p = forall wA wB. (FL p :\/: FL p) wA wB -> TestResult
+type SequenceProperty p = forall wA wB. RL p wA wB -> TestResult
+
[remove state parameter from WithStartState2
Ben Franksen <ben.franksen at online.de>**20200216182120
Ignore-this: 1457bcaaaa47a49d9b9a6694771ec63ce5ffbc5117e7b4fdfcca20542bd4034e3290bd77982183a8
This is similar to what I did to WithState and has the same advantages.
] hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 36
- - -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 45
- - -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 54
- - -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 63
- - -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> Maybe r
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 74
- - -> Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p)) -> r
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatch.hs 83
- - => Sealed2 (WithStartState2 (ModelOf p) (MergeableSequence p))
+ => Sealed2 (WithStartState2 (MergeableSequence p))
hunk ./harness/Darcs/Test/Patch/WithState.hs 65
- -data WithStartState2 s p wX wY =
+data WithStartState2 p wX wY =
hunk ./harness/Darcs/Test/Patch/WithState.hs 67
- - { wss2StartState :: s wX
+ { wss2StartState :: ModelOf p wX
hunk ./harness/Darcs/Test/Patch/WithState.hs 70
- - deriving Eq
hunk ./harness/Darcs/Test/Patch/WithState.hs 71
- -instance (Show1 s, Show2 p) => Show (WithStartState2 s p wX wY) where
+instance (Show1 (ModelOf p), Show2 p) => Show (WithStartState2 p wX wY) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 77
- -instance (Show1 s, Show2 p) => Show1 (WithStartState2 s p wX)
- -instance (Show1 s, Show2 p) => Show2 (WithStartState2 s p)
+instance (Show1 (ModelOf p), Show2 p) => Show1 (WithStartState2 p wX)
+instance (Show1 (ModelOf p), Show2 p) => Show2 (WithStartState2 p)
hunk ./harness/Darcs/Test/Patch/WithState.hs 250
+ , ModelOf p ~ s
hunk ./harness/Darcs/Test/Patch/WithState.hs 252
- - => Sealed2 (WithStartState2 s p)
- - -> [Sealed2 (WithStartState2 s p)]
+ => Sealed2 (WithStartState2 p)
+ -> [Sealed2 (WithStartState2 p)]
hunk ./harness/Darcs/Test/Patch/WithState.hs 260
- - :: ( Shrinkable p, RepoModel s, Effect p
+ :: ( Shrinkable p, RepoModel (ModelOf p), Effect p
hunk ./harness/Darcs/Test/Patch/WithState.hs 262
- - , ApplyState prim ~ RepoState s
+ , ApplyState prim ~ RepoState (ModelOf p)
hunk ./harness/Darcs/Test/Patch/WithState.hs 264
- - => WithStartState2 s p wX wY
- - -> [FlippedSeal (WithStartState2 s p) wY]
+ => WithStartState2 p wX wY
+ -> [FlippedSeal (WithStartState2 p) wY]
hunk ./harness/Darcs/Test/Patch/WithState.hs 279
- - => Arbitrary (Sealed2 (WithStartState2 s p)) where
+ => Arbitrary (Sealed2 (WithStartState2 p)) where
hunk ./harness/Darcs/Test/Patch/WithState.hs 293
- -withStateShrinking :: (forall wX wY. p wX wY -> r) -> Sealed2 (WithStartState2 (ModelOf p) p) -> r
+withStateShrinking :: (forall wX wY. p wX wY -> r) -> Sealed2 (WithStartState2 p) -> r
[tests: remove unused withStateShrinking
Ganesh Sittampalam <ganesh at earth.li>**20200223185148
Ignore-this: f92d3eba7ba0f6cef705f6aca04f67dc
] hunk ./harness/Darcs/Test/Patch/WithState.hs 290
- --- |Given a property on patches, wrap it with 'WithStartState2' so that we get shrinking of
- --- any counter-examples, including simplification of the underlying repository via
- --- 'ShrinkModel'/'PropagateShrink'.
- -withStateShrinking :: (forall wX wY. p wX wY -> r) -> Sealed2 (WithStartState2 p) -> r
- -withStateShrinking prop (Sealed2 (WithStartState2 _ p)) = prop p
- -
[tests: generalise hasPrimConstruct, add usesV1Model
Ganesh Sittampalam <ganesh at earth.li>**20200223185248
Ignore-this: 8cd25c449842921959640f9be9e566da
] hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 30
+import Darcs.Test.Patch.V1Model
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 44
- -import Darcs.Patch.Prim ( sortCoalesceFL, PrimCanonize )
+import Darcs.Patch.Prim ( sortCoalesceFL, PrimCanonize, PrimConstruct )
hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 120
- - hasPrimConstruct :: Bool
- - hasPrimConstruct = True
+ hasPrimConstruct :: Maybe (Dict (PrimConstruct prim))
+ default hasPrimConstruct :: PrimConstruct prim => Maybe (Dict (PrimConstruct prim))
+ hasPrimConstruct = Just Dict
+
+ usesV1Model :: Maybe (Dict (ModelOf prim ~ V1Model))
+ default usesV1Model :: ModelOf prim ~ V1Model => Maybe (Dict (ModelOf prim ~ V1Model))
+ usesV1Model = Just Dict
hunk ./harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs 31
- - hasPrimConstruct = False
+ hasPrimConstruct = Nothing
+ usesV1Model = Nothing
hunk ./harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs 32
- - hasPrimConstruct = False
+ hasPrimConstruct = Nothing
+ usesV1Model = Nothing
hunk ./harness/Darcs/Test/Patch/Rebase.hs 7
- -
+import Data.Maybe
hunk ./harness/Darcs/Test/Patch/Rebase.hs 26
- - if hasPrimConstruct @(PrimOf p)
+ if isJust (hasPrimConstruct @(PrimOf p))
[tests: introduce method to identify V1 patch type
Ganesh Sittampalam <ganesh at earth.li>**20200223185254
Ignore-this: 849fda1df95ae316c1acf9f24d3ea9fb
] hunk ./darcs.cabal 633
+ EmptyCase
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 9
- - , ArbitraryRepoPatch
+ , NotRepoPatchV1(..)
+ , ArbitraryRepoPatch(..)
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 25
- -
- --- | Constraint synonym to simplify type signatures and superclass constraints.
- -type ArbitraryRepoPatch p =
+import Darcs.Patch.V1 ( RepoPatchV1 )
+
+import Data.Constraint
+import Data.Void
+
+data NotRepoPatchV1 p = NotRepoPatchV1 (forall prim . Dict (p ~ RepoPatchV1 prim) -> Void)
+
+-- | Class to simplify type signatures and superclass constraints.
+class
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 38
- - )
+ ) => ArbitraryRepoPatch p where
+
+ notRepoPatchV1 :: Maybe (NotRepoPatchV1 p)
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 37
+import Darcs.Patch
+import Darcs.Patch.Annotate
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 55
+import Darcs.Test.Patch.Arbitrary.RepoPatch
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 57
- -import Darcs.Test.Patch.RepoModel ( ModelOf )
+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs 68
+instance
+ (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))
+ => ArbitraryRepoPatch (RepoPatchV1 prim)
+ where
+
+ notRepoPatchV1 = Nothing
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 10
+import Darcs.Test.Patch.Arbitrary.RepoPatch
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 12
- -import Darcs.Test.Patch.RepoModel ( ModelOf )
+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 14
+import Darcs.Patch
+import Darcs.Patch.Annotate
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs 26
+instance
+ (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))
+ => ArbitraryRepoPatch (RepoPatchV2 prim)
+ where
+
+ notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))
+
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 8
+import Darcs.Test.Patch.Arbitrary.RepoPatch
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 10
- -import Darcs.Test.Patch.RepoModel ( ModelOf )
+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 13
- -import Darcs.Patch.Prim.Class
+import Darcs.Patch
+import Darcs.Patch.Annotate
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs 27
+instance
+ (Annotate prim, ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))
+ => ArbitraryRepoPatch (RepoPatchV3 prim)
+ where
+
+ notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))
+
[tests: add withAllSequenceItems
Ganesh Sittampalam <ganesh at earth.li>**20200223185442
Ignore-this: f5f69ad3058c02f93a6b7a43673a4b3
] hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 9
+ , withAllSequenceItems
hunk ./harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs 89
+withAllSequenceItems
+ :: (CheckedMerge p, PrimBased p, Monoid r)
+ => (forall wX wY. p wX wY -> r)
+ -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r
+withAllSequenceItems prop (Sealed2 (WithStartState2 _ ms))
+ = mconcat . mapRL prop . mergeableSequenceToRL $ ms
+
+
hunk ./harness/Darcs/Test/Util/TestResult.hs 21
+-- |Indicate the result of a test, which could be success,
+-- failure (with a reason), or that the test couldn't run (rejected),
+-- perhaps because the input data didn't meet some pre-condition.
+-- The Monoid instance combines results by failing if either result
+-- failed, rejecting if both results are rejected, and otherwise
+-- succeeding.
hunk ./harness/Darcs/Test/Util/TestResult.hs 51
+-- Specialised version of 'mconcat'.
hunk ./harness/Darcs/Test/Util/TestResult.hs 53
- -combineTestResults = foldr (<&&>) TestRejected
+combineTestResults = mconcat
+
+instance Semigroup TestResult where
+ (<>) = (<&&>)
+
+instance Monoid TestResult where
+ mempty = TestRejected
[tests: add a TODO about merging hasPrimConstruct/usesV1Model
Ganesh Sittampalam <ganesh at earth.li>**20200225070902
Ignore-this: e0674ebe48616d5abd830141fbba6660
] hunk ./harness/Darcs/Test/Patch/Arbitrary/Generic.hs 120
+ -- TODO in practice both hasPrimConstruct and usesV1Model will only work for V1 prims
+ -- and their newtypes. Consider merging into one method.
+
[tests: add mappend TestResult for old GHC compatibility
Ganesh Sittampalam <ganesh at earth.li>**20200225073438
Ignore-this: 8e88256ecfbfcac83f23a432c23d2a91
] hunk ./harness/Darcs/Test/Util/TestResult.hs 60
+ mappend = (<>)
[tests: use Semigroup TestResult consistently
Ganesh Sittampalam <ganesh at earth.li>**20200225080453
Ignore-this: d189fea5cf36d67d0960f9c2e6809213
] hunk ./harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs 10
- -import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, (<&&>) )
+import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed )
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs 35
- - prop_repoInvariants ps <&&>
- - prop_positiveId p <&&>
- - prop_uniqueId ps p <&&>
- - prop_consistentConflictor p <&&>
- - prop_onlyFirstConflictorReverts ps p <&&>
- - prop_conflictsCommutePastConflictor ps p <&&>
+ prop_repoInvariants ps <>
+ prop_positiveId p <>
+ prop_uniqueId ps p <>
+ prop_consistentConflictor p <>
+ prop_onlyFirstConflictorReverts ps p <>
+ prop_conflictsCommutePastConflictor ps p <>
hunk ./harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs 139
- - allSucceeded = foldr (<&&>) succeeded
+ allSucceeded = foldr (<>) succeeded
hunk ./harness/Darcs/Test/Patch/Properties/V1Set1.hs 114
- - <&&>
+ <>
hunk ./harness/Darcs/Test/Util/TestResult.hs 6
- - , (<&&>)
- - , combineTestResults
hunk ./harness/Darcs/Test/Util/TestResult.hs 39
- --- | Succeed even if one of the arguments is rejected.
- -(<&&>) :: TestResult -> TestResult -> TestResult
- -t@(TestFailed _) <&&> _s = t
- -_t <&&> s@(TestFailed _) = s
- -TestRejected <&&> s = s
- -t <&&> TestRejected = t
- -TestSucceeded <&&> TestSucceeded = TestSucceeded
- -
- --- | Fail if any element fails, reject if all elements
- --- are rejected, otherwise succeed.
- --- Specialised version of 'mconcat'.
- -combineTestResults :: [TestResult] -> TestResult
- -combineTestResults = mconcat
- -
hunk ./harness/Darcs/Test/Util/TestResult.hs 40
- - (<>) = (<&&>)
+ -- Succeed even if one of the arguments is rejected.
+ t@(TestFailed _) <> _s = t
+ _t <> s@(TestFailed _) = s
+ TestRejected <> s = s
+ t <> TestRejected = t
+ TestSucceeded <> TestSucceeded = TestSucceeded
[update indentation of instance ShowPatchBasic RebaseChange
Ganesh Sittampalam <ganesh at earth.li>**20200303132132
Ignore-this: 45cc8ed2eb02558f93cdcddc3c9ead70
] hunk ./src/Darcs/Patch/Rebase/Viewing.hs 129
- - showPatch ForStorage _ = error "impossible case"
- - showPatch ForDisplay (RC fixups contents) =
- - vcat (mapFL (showPatch ForDisplay) (patchcontents contents)) $$
- - (if nullFL fixups
- - then empty
- - else
- - redText "" $$
- - redText "conflicts:" $$
- - redText "" $$
- - vcat (mapRL showFixup (invertFL fixups))
- - )
- - where
- - showFixup (PrimFixup p) = showPatch ForDisplay p
- - showFixup (NameFixup n) = showPatch ForDisplay n
+ showPatch ForStorage _ = error "impossible case"
+ showPatch ForDisplay (RC fixups contents) =
+ vcat (mapFL (showPatch ForDisplay) (patchcontents contents)) $$
+ (if nullFL fixups
+ then empty
+ else
+ redText "" $$
+ redText "conflicts:" $$
+ redText "" $$
+ vcat (mapRL showFixup (invertFL fixups))
+ )
+ where
+ showFixup (PrimFixup p) = showPatch ForDisplay p
+ showFixup (NameFixup n) = showPatch ForDisplay n
[cut back some constraints on RebaseChange instances
Ganesh Sittampalam <ganesh at earth.li>**20200305070413
Ignore-this: 6332f1b42c3e5b64a9f4dd18a31f021b
This is primarily to make future refactoring easier.
] hunk ./src/Darcs/Patch/Rebase/Viewing.hs 128
- -instance RepoPatch p => ShowPatchBasic (RebaseChange p) where
+instance (PrimPatchBase p, ShowPatchBasic p) => ShowPatchBasic (RebaseChange p) where
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 144
- -instance RepoPatch p => ShowPatch (RebaseChange p) where
+instance (PrimPatchBase p, ShowPatch p, Effect p, Summary p, PatchListFormat p)
+ => ShowPatch (RebaseChange p) where
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 187
- -instance RepoPatch p => PatchInspect (RebaseChange p) where
+instance (PatchInspect (PrimOf p), PatchInspect p) => PatchInspect (RebaseChange p) where
[remove an obsolete TODO comment
Ben Franksen <ben.franksen at online.de>**20200523121847
Ignore-this: eda2139fb90f847d78f4aa0391b8fb4a304e87aa2a01653f9629ab0d432f7a0a8593ebc432a34aa6
] hunk ./src/Darcs/Repository/Hashed.hs 771
- --- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun
- --- :: Bool, with dryRun = unsafePerformIO $ readIORef ...
[conflicted rebase: first steps
Ben Franksen <ben.franksen at online.de>**20200523115948
Ignore-this: afe5de8c83c0ecd1f489277e2dd0cbecffe7bc58eae408497bc7b99c588079bd0ff24b8de5e2502d
] hunk ./src/Darcs/Patch/Named/Wrapped.hs 20
+import Darcs.Patch.Merge ( Merge )
hunk ./src/Darcs/Patch/Named/Wrapped.hs 34
+import Darcs.Patch.Witnesses.Eq ( Eq2 )
hunk ./src/Darcs/Patch/Named/Wrapped.hs 131
- -instance (ReadPatch p, PatchListFormat p, PrimPatchBase p) => ReadPatch (ReadRebasing p) where
+instance (ReadPatch p, PatchListFormat p) => ReadPatch (ReadRebasing p) where
hunk ./src/Darcs/Patch/Named/Wrapped.hs 148
- -instance Commute p => Commute (WrappedNamed rt p) where
+instance (Commute p, Eq2 p, Merge p) => Commute (WrappedNamed rt p) where
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 19
- -import Darcs.Patch.Effect ( Effect(..) )
- -import Darcs.Patch.FromPrim ( FromPrim(..) )
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 23
- -import Darcs.Patch.Prim ( PrimPatch, canonizeFL )
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 31
- -import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 36
- -import qualified Darcs.Util.Diff as D ( DiffAlgorithm )
- -
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 38
- -data RebaseFixup prim wX wY where
- - PrimFixup :: prim wX wY -> RebaseFixup prim wX wY
- - NameFixup :: RebaseName wX wY -> RebaseFixup prim wX wY
+data RebaseFixup p wX wY where
+ PrimFixup :: p wX wY -> RebaseFixup p wX wY
+ NameFixup :: RebaseName wX wY -> RebaseFixup p wX wY
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 42
- -namedToFixups :: (PrimPatch (PrimOf p), Effect p) => Named p wX wY -> FL (RebaseFixup (PrimOf p)) wX wY
- -namedToFixups (NamedP p _ contents) = NameFixup (AddName p) :>: mapFL_FL PrimFixup (effect contents)
+namedToFixups :: Named p wX wY -> FL (RebaseFixup p) wX wY
+namedToFixups (NamedP p _ contents) =
+ NameFixup (AddName p) :>: mapFL_FL PrimFixup contents
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 46
- -instance Show2 prim => Show (RebaseFixup prim wX wY) where
+instance Show2 p => Show (RebaseFixup p wX wY) where
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 52
- -instance Show2 prim => Show1 (RebaseFixup prim wX)
+instance Show2 p => Show1 (RebaseFixup p wX)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 54
- -instance Show2 prim => Show2 (RebaseFixup prim)
+instance Show2 p => Show2 (RebaseFixup p)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 56
- -instance PrimPatch prim => PrimPatchBase (RebaseFixup prim) where
- - type PrimOf (RebaseFixup prim) = prim
+instance PrimPatchBase p => PrimPatchBase (RebaseFixup p) where
+ type PrimOf (RebaseFixup p) = PrimOf p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 59
- -instance Apply prim => Apply (RebaseFixup prim) where
- - type ApplyState (RebaseFixup prim) = ApplyState prim
+instance Apply p => Apply (RebaseFixup p) where
+ type ApplyState (RebaseFixup p) = ApplyState p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 66
- -instance Invert prim => Invert (RebaseFixup prim) where
+instance Invert p => Invert (RebaseFixup p) where
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 70
- -instance PatchInspect prim => PatchInspect (RebaseFixup prim) where
+instance PatchInspect p => PatchInspect (RebaseFixup p) where
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 77
- -instance Commute prim => Commute (RebaseFixup prim) where
+instance Commute p => Commute (RebaseFixup p) where
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 94
- -pushFixupPrim
- - :: PrimPatch prim
- - => D.DiffAlgorithm
- - -> PushFixupFn prim prim (FL prim) (Maybe2 prim)
- -pushFixupPrim da (f1 :> f2)
- - | IsEq <- isInverse = NilFL :> Nothing2
- - | otherwise
- - = case commute (f1 :> f2) of
- - Nothing -> canonizeFL da (f1 :>: f2 :>: NilFL) :> Nothing2
- - Just (f2' :> f1') -> (f2' :>: NilFL) :> Just2 f1'
- - where isInverse = invert f1 =\/= f2
- -
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 95
- - :: PrimPatch prim
- - => D.DiffAlgorithm
- - -> PushFixupFn
- - (RebaseFixup prim) (RebaseFixup prim)
- - (FL (RebaseFixup prim)) (Maybe2 (RebaseFixup prim))
+ :: Commute p
+ => PushFixupFn
+ (RebaseFixup p) (RebaseFixup p)
+ (FL (RebaseFixup p)) (Maybe2 (RebaseFixup p))
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 100
- -pushFixupFixup da (PrimFixup f1 :> PrimFixup f2)
- - = case pushFixupPrim da (f1 :> f2) of
- - fs2' :> f1' -> mapFL_FL PrimFixup fs2' :> mapMB_MB PrimFixup f1'
+pushFixupFixup (PrimFixup f1 :> PrimFixup f2)
+ = case commute (f1 :> f2) of
+ Just (f2' :> f1') -> PrimFixup f2' :>: NilFL :> Just2 (PrimFixup f1')
+ Nothing -> PrimFixup f1 :>: PrimFixup f2 :>: NilFL :> Nothing2
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 105
- -pushFixupFixup _da (PrimFixup f :> NameFixup n)
+pushFixupFixup (PrimFixup f :> NameFixup n)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 109
- -pushFixupFixup _da (NameFixup n1 :> NameFixup n2)
+pushFixupFixup (NameFixup n1 :> NameFixup n2)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 113
- -pushFixupFixup _da (NameFixup n :> PrimFixup f)
+pushFixupFixup (NameFixup n :> PrimFixup f)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 119
- -flToNamesPrims :: FL (RebaseFixup prim) wX wY
- - -> (FL RebaseName :> FL prim) wX wY
+flToNamesPrims :: FL (RebaseFixup p) wX wY
+ -> (FL RebaseName :> FL p) wX wY
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 131
- --- Note that this produces a list result because of the need to use effect to
- --- extract the result.
- --- Some general infrastructure for commuting p with PrimOf p would be helpful here,
- -commuteNamedPrim :: (FromPrim p, Effect p, Commute p)
- - => (Named p :> PrimOf p) wX wY
- - -> Maybe ((FL (PrimOf p) :> Named p) wX wY)
- -commuteNamedPrim (p :> q) = do
- - q' :> p' <- commuterNamedId selfCommuter (p :> fromAnonymousPrim q)
- - return (effect q' :> p')
- -
- -commutePrimNamed :: (FromPrim p, Effect p, Commute p)
- - => (PrimOf p :> Named p) wX wY
- - -> Maybe ((Named p :> FL (PrimOf p)) wX wY)
- -commutePrimNamed (p :> q) = do
- - q' :> p' <- commuterIdNamed selfCommuter (fromAnonymousPrim p :> q)
- - return (q' :> effect p')
- -
- -commuteNamedFixup :: (FromPrim p, Effect p, Commute p, prim ~ PrimOf p)
- - => (Named p :> RebaseFixup prim) wX wY
- - -> Maybe ((FL (RebaseFixup prim) :> Named p) wX wY)
+commuteNamedFixup :: Commute p
+ => (Named p :> RebaseFixup p) wX wY
+ -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 135
- - qs' :> p' <- commuteNamedPrim (p :> q)
- - return (mapFL_FL PrimFixup qs' :> p')
+ q' :> p' <- commuterNamedId selfCommuter (p :> q)
+ return (PrimFixup q' :>: NilFL :> p')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 141
- -
- -commuteNamedFixups :: (FromPrim p, Effect p, Commute p, prim ~ PrimOf p)
- - => (Named p :> FL (RebaseFixup prim)) wX wY
- - -> Maybe ((FL (RebaseFixup prim) :> Named p) wX wY)
+commuteNamedFixups :: Commute p
+ => (Named p :> FL (RebaseFixup p)) wX wY
+ -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 150
- -
- -commuteFixupNamed :: (FromPrim p, Effect p, Commute p, prim ~ PrimOf p)
- - => (RebaseFixup prim :> Named p) wX wY
- - -> Maybe ((Named p :> FL (RebaseFixup prim)) wX wY)
+commuteFixupNamed :: Commute p
+ => (RebaseFixup p :> Named p) wX wY
+ -> Maybe ((Named p :> FL (RebaseFixup p)) wX wY)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 154
- - q' :> ps' <- commutePrimNamed (p :> q)
- - return (q' :> mapFL_FL PrimFixup ps')
+ q' :> p' <- commuterIdNamed selfCommuter (p :> q)
+ return (q' :> PrimFixup p' :>: NilFL)
hunk ./src/Darcs/Patch/Rebase/Item.hs 6
+ , removeFixups
hunk ./src/Darcs/Patch/Rebase/Item.hs 12
- -import Darcs.Patch.Effect ( Effect(..) )
hunk ./src/Darcs/Patch/Rebase/Item.hs 14
- -import Darcs.Patch.Named ( Named(..) )
+import Darcs.Patch.Named ( Named(..), mergerIdNamed )
hunk ./src/Darcs/Patch/Rebase/Item.hs 18
+import Darcs.Patch.Invert ( Invert(..) )
+import Darcs.Patch.Merge ( Merge(..) )
+import Darcs.Patch.Permutations ( removeFL )
hunk ./src/Darcs/Patch/Rebase/Item.hs 24
- - ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..) )
+ ( PrimPatchBase, PrimOf )
hunk ./src/Darcs/Patch/Rebase/Item.hs 28
+import Darcs.Patch.Rebase.Name ( commuteNamePrim )
hunk ./src/Darcs/Patch/Rebase/Item.hs 34
- -import Darcs.Patch.Summary ( Summary(..), plainSummaryPrim )
+import Darcs.Patch.Summary ( Summary(..), plainSummary )
hunk ./src/Darcs/Patch/Rebase/Item.hs 36
+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
hunk ./src/Darcs/Patch/Rebase/Item.hs 41
- -import qualified Darcs.Util.Diff as D ( DiffAlgorithm )
hunk ./src/Darcs/Patch/Rebase/Item.hs 67
- - Fixup :: RebaseFixup (PrimOf p) wX wY -> RebaseItem p wX wY
+ Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY
hunk ./src/Darcs/Patch/Rebase/Item.hs 81
- --- the list as possible, using both commutation and coalescing. If the fixup
+-- the list as possible using commutation. If the fixup
hunk ./src/Darcs/Patch/Rebase/Item.hs 83
- -simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm -> RebaseFixup (PrimOf p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
- -simplifyPush da fixup items = dropFixups $ pushFixupItems da (fixup :> items)
+simplifyPush :: Commute p
+ => RebaseFixup p wX wY
+ -> FL (RebaseItem p) wY wZ
+ -> Sealed (FL (RebaseItem p) wX)
+simplifyPush fixup items = dropFixups $ pushFixupItems (fixup :> items)
hunk ./src/Darcs/Patch/Rebase/Item.hs 90
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm
- - -> PushFixupFn
- - (RebaseFixup (PrimOf p)) (RebaseItem p)
- - (FL (RebaseItem p)) (FL (RebaseFixup (PrimOf p)))
- -pushFixupItem da (f1 :> Fixup f2)
- - = case pushFixupFixup da (f1 :> f2) of
+ :: Commute p
+ => PushFixupFn
+ (RebaseFixup p) (RebaseItem p)
+ (FL (RebaseItem p)) (FL (RebaseFixup p))
+pushFixupItem (f1 :> Fixup f2)
+ = case pushFixupFixup (f1 :> f2) of
hunk ./src/Darcs/Patch/Rebase/Item.hs 98
- -pushFixupItem _da (f :> ToEdit e)
+pushFixupItem (f :> ToEdit e)
hunk ./src/Darcs/Patch/Rebase/Item.hs 105
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm
- - -> PushFixupFn
- - (RebaseFixup (PrimOf p)) (FL (RebaseItem p))
- - (FL (RebaseItem p)) (FL (RebaseFixup (PrimOf p)))
- -pushFixupItems da = pushFixupFLFL_FLFLFL (pushFixupItem da)
+ :: Commute p
+ => PushFixupFn
+ (RebaseFixup p) (FL (RebaseItem p))
+ (FL (RebaseItem p)) (FL (RebaseFixup p))
+pushFixupItems = pushFixupFLFL_FLFLFL pushFixupItem
hunk ./src/Darcs/Patch/Rebase/Item.hs 113
- -simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm -> FL (RebaseFixup (PrimOf p)) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
- -simplifyPushes _ NilFL ps = Sealed ps
- -simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)
+simplifyPushes :: Commute p
+ => FL (RebaseFixup p) wX wY
+ -> FL (RebaseItem p) wY wZ
+ -> Sealed (FL (RebaseItem p) wX)
+simplifyPushes NilFL ps = Sealed ps
+simplifyPushes (f :>: fs) ps = unseal (simplifyPush f) (simplifyPushes fs ps)
hunk ./src/Darcs/Patch/Rebase/Item.hs 120
- -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where
+instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where
hunk ./src/Darcs/Patch/Rebase/Item.hs 129
- - summary (Fixup (PrimFixup p)) = plainSummaryPrim p
+ summary (Fixup (PrimFixup p)) = plainSummary p
hunk ./src/Darcs/Patch/Rebase/Item.hs 134
- -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where
+instance (PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where
hunk ./src/Darcs/Patch/Rebase/Item.hs 145
- -instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseItem p) where
+instance PatchInspect p => PatchInspect (RebaseItem p) where
hunk ./src/Darcs/Patch/Rebase/Item.hs 151
+
+removeFixups :: (Commute p, Eq2 p, Merge p)
+ => FL (RebaseFixup p) wX wY
+ -> FL (RebaseItem p) wX wZ
+ -> Sealed (FL (RebaseItem p) wY)
+removeFixups NilFL qs = Sealed qs
+removeFixups (p :>: ps) qs =
+ case removeFixup p qs of
+ Sealed qs' -> removeFixups ps qs'
+
+removeFixup :: (Commute p, Eq2 p, Merge p)
+ => RebaseFixup p wX wY
+ -> FL (RebaseItem p) wX wZ
+ -> Sealed (FL (RebaseItem p) wY)
+removeFixup _ NilFL = Sealed NilFL
+removeFixup (NameFixup p) qs =
+ simplifyPush (NameFixup (invert p)) qs
+removeFixup (PrimFixup p) (ToEdit q :>: qs)
+ | Just q' <- removeFromNamed p q = Sealed (ToEdit q' :>: qs)
+ | otherwise =
+ case mergerIdNamed merge (p :\/: q) of
+ q' :/\: p' ->
+ case removeFixup (PrimFixup p') qs of
+ Sealed qs' -> Sealed (ToEdit q' :>: qs')
+removeFixup (PrimFixup p) (Fixup (PrimFixup q) :>: qs)
+ | IsEq <- p =\/= q = Sealed qs
+ | otherwise =
+ case merge (p :\/: q) of
+ q' :/\: p' ->
+ case removeFixup (PrimFixup p') qs of
+ Sealed qs' -> Sealed (Fixup (PrimFixup q') :>: qs')
+removeFixup (PrimFixup p) (Fixup (NameFixup q) :>: qs) =
+ case commuteNamePrim (invert q :> p) of
+ p' :> iq' ->
+ case removeFixup (PrimFixup p') qs of
+ Sealed qs' -> Sealed (Fixup (NameFixup (invert iq')) :>: qs')
+
+removeFromNamed :: (Commute p, Eq2 p)
+ => p wX wY -> Named p wX wZ -> Maybe (Named p wY wZ)
+removeFromNamed p (NamedP n ds ps) = NamedP n ds <$> removeFL p ps
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 11
- -import Darcs.Patch.Effect ( Effect(..) )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 12
- -import Darcs.Patch.Invert ( invert )
- -import Darcs.Patch.Named ( Named )
+import Darcs.Patch.Named ( Named(..) )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 15
+import Darcs.Patch.Merge ( Merge(..) )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 17
- -import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) )
+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 20
- -import Darcs.Patch.Rebase.Item ( RebaseItem(..) )
+import Darcs.Patch.Rebase.Item ( RebaseItem(..), removeFixups )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 24
+import Darcs.Patch.Witnesses.Eq ( Eq2 )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 29
- -import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 50
- -instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where
+instance (PatchInspect p) => PatchInspect (Suspended p) where
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 54
- -instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where
+instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 56
- - = blueText "rebase" <+> text "0.0" <+> blueText "{"
+ = blueText "rebase" <+> text "1.0" <+> blueText "{"
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 60
- -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where
+instance (PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 64
- - when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version
+ when (version /= BC.pack "1.0") $ error $ "can't handle rebase version " ++ show version
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 78
- --- |add fixups for the name and effect of a patch to a 'Suspended'
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 79
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
+ :: Commute p
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 83
- -addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p)
+addFixupsToSuspended p = simplifyPushes (namedToFixups p)
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 85
- --- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended'
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 86
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
+ :: (Commute p, Eq2 p, Merge p)
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 90
- -removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p))
+removeFixupsFromSuspended p (Items ps) =
+ case removeFixups (namedToFixups p) ps of
+ Sealed ps' -> Items ps'
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 95
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm
- - -> RebaseFixup (PrimOf p) wX wY
+ :: Commute p
+ => RebaseFixup p wX wY
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 99
- -simplifyPush da fixups = onSuspended (Item.simplifyPush da fixups)
+simplifyPush fixups = onSuspended (Item.simplifyPush fixups)
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 102
- - :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
- - => D.DiffAlgorithm
- - -> FL (RebaseFixup (PrimOf p)) wX wY
+ :: Commute p
+ => FL (RebaseFixup p) wX wY
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 106
- -simplifyPushes da fixups = onSuspended (Item.simplifyPushes da fixups)
+simplifyPushes fixups = onSuspended (Item.simplifyPushes fixups)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 25
- - , MergeFn
- - , commuterFLId
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 33
- -import Darcs.Patch.Invert ( invert, invertFL )
- -import Darcs.Patch.Merge ( selfMerger )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 37
- - , mergerIdNamed
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 45
- -import Darcs.Patch.Summary ( Summary(..), ConflictState(..), IsConflictedPrim(..) )
+import Darcs.Patch.Summary ( Summary(..) )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 47
- -import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 57
- -import Darcs.Patch.Summary ( plainSummary, plainSummaryFL )
+import Darcs.Patch.Summary ( plainSummary )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 63
- -import Darcs.Util.Printer ( ($$), redText, empty, vcat )
+import Darcs.Util.Printer ( ($$), blueText, prefix, text, vcat )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 69
- - RC :: FL (RebaseFixup (PrimOf p)) wX wY -> Named p wY wZ -> RebaseChange p wX wZ
+ RC :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseChange p wX wZ
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 100
- -instance (Effect p, Summary p, Commute (PrimOf p)) => Summary (RebaseChange p) where
+instance Summary p => Summary (RebaseChange p) where
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 103
- - _names :> prims ->
- - -- Report on the conflicts we would get if we unsuspended just this patch.
- - -- An alternative implementation strategy would be to "force commute"
- - -- prims :> toedit and report on the resulting conflicts in toedit.
- - -- However this ties us to a specific RepoPatch type which isn't really
- - -- needed for a simple calculation like this.
- - --
- - -- The rebase invariants should mean that 'fixups' (if non-empty) won't
- - -- commute with 'changes' as a whole, but here we need to report each individual
- - -- prim as conflicted or not, so we try to push the fixups as far through
- - -- the individual prims as we can.
- - --
- - -- Taking the effect also means that any conflicts already present in the
- - -- suspended patch won't be reported, but in general such conflicts
- - -- are not supported anyway.
- - case genCommuteWhatWeCanFL (commuterFLId commute) (prims :> effect toedit) of
- - unconflicted :> _ :> conflicted ->
- - mapFL (IsC Okay) unconflicted ++ mapFL (IsC Conflicted) conflicted
+ _names :> ps -> conflictedEffect (ps +>+ patchcontents toedit)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 105
- -instance (PrimPatchBase p, ShowPatchBasic p) => ShowPatchBasic (RebaseChange p) where
+instance (PatchListFormat p, ShowPatchBasic p) =>
+ ShowPatchBasic (RebaseChange p) where
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 108
- - showPatch ForDisplay (RC fixups contents) =
- - vcat (mapFL (showPatch ForDisplay) (patchcontents contents)) $$
- - (if nullFL fixups
- - then empty
- - else
- - redText "" $$
- - redText "conflicts:" $$
- - redText "" $$
- - vcat (mapRL showFixup (invertFL fixups))
- - )
+ showPatch ForDisplay (RC fixups toedit) =
+ vcat (mapFL showFixup fixups) $$
+ showPatch ForDisplay toedit
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 112
- - showFixup (PrimFixup p) = showPatch ForDisplay p
+ showFixup (PrimFixup p) = blueText "fixup" $$ showPatch ForDisplay p
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 118
- - summary = plainSummary
- - summaryFL = plainSummaryFL
+ summary p = description p $$ text "" $$ prefix " " (plainSummary p)
+ summaryFL = vcat . mapFL summary
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 158
- -instance (PatchInspect (PrimOf p), PatchInspect p) => PatchInspect (RebaseChange p) where
+instance PatchInspect p => PatchInspect (RebaseChange p) where
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 206
- - => (FL (RebaseFixup (PrimOf p)) :> (FL (RebaseFixup (PrimOf p)) :> Named p)) wX wY
- - -> (FL (RebaseFixup (PrimOf p)) :> (FL (RebaseFixup (PrimOf p)) :> Named p) :> FL (RebaseFixup (PrimOf p))) wX wY
+ => (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p)) wX wY
+ -> (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p) :> FL (RebaseFixup p)) wX wY
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 220
- -mergerIdWDD :: MergeFn p1 p2 -> MergeFn p1 (WithDroppedDeps p2)
- -mergerIdWDD merger (p1 :\/: WithDroppedDeps p2 deps) =
- - case merger (p1 :\/: p2) of
- - p2' :/\: p1' -> WithDroppedDeps p2' deps :/\: p1'
- -
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 242
- - | dn == pn = error "impossible case"
+ | dn == pn =
+ -- this case happens when we suspend and then re-pull
+ unsafeCoerceP p :> DelName dn
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 255
- -forceCommutePrim :: RepoPatch p
- - => (PrimOf p :> WDDNamed p) wX wY
- - -> (WDDNamed p :> FL (PrimOf p)) wX wY
- -forceCommutePrim (p :> wq) =
- - -- rp and irp are not inverses for RepoPatchV3, only their effects are inverse
- - let rp = fromAnonymousPrim p
- - irp = fromAnonymousPrim (invert p)
- - in case mergerIdWDD (mergerIdNamed selfMerger) (irp :\/: wq) of
- - wq' :/\: irp' -> prefixWith (rp :>: irp :>: NilFL) wq' :> invert (effect irp')
- - where
- - -- TODO [V3INTEGRATION]:
- - -- This is a hack to adapt forceCommutePrim to the stricter assumptions
- - -- made by RepoPatchV3, for which resolveConflicts expects that we can
- - -- find each patch we conflict with somewhere in the context.
- - -- Force-commuting the fixups with the patch to be edited violates that
- - -- assumption. It works for RepoPatchV1/2 because their conflictors are
- - -- self-contained i.e. they contain the transitive set of conflicts in
- - -- their representation, which is no longer true for RepoPatchV3.
- - -- To restore the assumption for RepoPatchV3 we prefix the patches
- - -- contained in the 'Named' patch with (rp;irp). The conflictor wq' can
- - -- now refer to irp, and the effect of rp will cancel with that of irp
- - -- on unsuspend.
- - prefixWith xs (WithDroppedDeps (NamedP i ds ps) dds) =
- - WithDroppedDeps (NamedP i ds (xs +>+ ps)) dds
- -
- -forceCommutesPrim :: RepoPatch p
- - => (PrimOf p :> FL (WDDNamed p)) wX wY
- - -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY
- -forceCommutesPrim (p :> NilFL) = NilFL :> (p :>: NilFL)
- -forceCommutesPrim (p :> (q :>: qs)) =
- - case forceCommutePrim (p :> q) of
- - q' :> p' -> case forceCommutessPrim ( p' :> qs) of
- - qs' :> p'' -> (q' :>: qs') :> p''
- -
- -forceCommutessPrim :: RepoPatch p
- - => (FL (PrimOf p) :> FL (WDDNamed p)) wX wY
- - -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY
- -forceCommutessPrim (NilFL :> qs) = qs :> NilFL
- -forceCommutessPrim ((p :>: ps) :> qs) =
- - case forceCommutessPrim (ps :> qs) of
- - qs' :> ps' ->
- - case forceCommutesPrim (p :> qs') of
- - qs'' :> p' -> qs'' :> (p' +>+ ps')
- -
- -forceCommutess :: RepoPatch p
- - => (FL (RebaseFixup (PrimOf p)) :> FL (WDDNamed p)) wX wY
- - -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY
- -forceCommutess (NilFL :> qs) = qs :> NilFL
- -forceCommutess ((NameFixup n :>: ps) :> qs) =
- - case forceCommutess (ps :> qs) of
- - qs' :> ps' ->
- - case totalCommuterIdFL forceCommuteName (n :> qs') of
- - qs'' :> n' -> qs'' :> (NameFixup n' :>: ps')
- -forceCommutess ((PrimFixup p :>: ps) :> qs) =
- - case forceCommutess (ps :> qs) of
- - qs' :> ps' ->
- - case forceCommutesPrim (p :> qs') of
- - qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')
- -
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 261
- - -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY
+ -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 266
- - case forceCommutess (fixups :> (WithDroppedDeps toedit [] :>: toedits2)) of
+ case injects (fixups :> (WithDroppedDeps toedit [] :>: toedits2)) of
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 270
+injects :: RepoPatch p
+ => (FL (RebaseFixup p) :> FL (WDDNamed p)) wX wY
+ -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY
+injects (NilFL :> qs) = qs :> NilFL
+injects ((NameFixup n :>: ps) :> qs) =
+ case injects (ps :> qs) of
+ qs' :> ps' ->
+ case totalCommuterIdFL forceCommuteName (n :> qs') of
+ qs'' :> n' -> qs'' :> (NameFixup n' :>: ps')
+injects ((PrimFixup p :>: ps) :> qs) =
+ case injects (ps :> qs) of
+ qs' :> ps' ->
+ case injectOne (p :> qs') of
+ qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')
+
+injectOne :: (p :> FL (WDDNamed p)) wX wY
+ -> (FL (WDDNamed p) :> FL p) wX wY
+injectOne (p :> NilFL) = NilFL :> (p :>: NilFL)
+injectOne (p :> (WithDroppedDeps (NamedP n ds q) dropped :>: qs)) =
+ WithDroppedDeps (NamedP n ds (p :>: q)) dropped :>: qs :> NilFL
+
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 293
- -reifyRebaseChange :: FromPrim p
+reifyRebaseChange :: forall p wX wY. (Effect p, FromPrim p)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 296
- - -> IO ((FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY)
+ -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 301
- - reifyOne :: FromPrim p => RebaseChange p wA wB -> IO (FL (WDDNamed p) wA wB)
+ reifyOne :: RebaseChange p wA wB -> IO (FL (WDDNamed p) wA wB)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 315
- -mkReified :: FromPrim p => String -> FL (PrimOf p) wX wY -> IO (Named p wX wY)
+mkReified :: forall p wX wY. (Effect p, FromPrim p)
+ => String -> FL p wX wY -> IO (Named p wX wY)
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 322
- - return $ infopatch info ps
+ case concatFL (mapFL_FL effect ps) of
+ (prims :: FL (PrimOf p) wX wY) -> return $ infopatch info prims
hunk ./src/Darcs/Repository/Rebase.hs 42
- -import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf )
+import Darcs.Patch.RepoPatch ( RepoPatch )
hunk ./src/Darcs/Repository/Rebase.hs 70
- -import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )
hunk ./src/Darcs/Repository/Rebase.hs 82
- - -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup (PrimOf p)) wT2 wT1, x))
+ -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
hunk ./src/Darcs/Repository/Rebase.hs 90
- - writeTentativeRebase r' (simplifyPushes MyersDiff fixups susp)
+ writeTentativeRebase r' (simplifyPushes fixups susp)
hunk ./src/Darcs/UI/Commands/Amend.hs 61
+import Darcs.Patch.FromPrim ( fromAnonymousPrim )
hunk ./src/Darcs/UI/Commands/Amend.hs 327
- - mapFL_FL PrimFixup (invert chs) +>+
+ mapFL_FL (PrimFixup . fromAnonymousPrim) (invert chs) +>+
hunk ./src/Darcs/UI/Commands/Rebase.hs 358
- - let da = diffAlgorithm ? opts
- - ps_to_keep = simplifyPushes da chosen_fixups .
+ let ps_to_keep = simplifyPushes chosen_fixups .
hunk ./src/Darcs/UI/Commands/Rebase.hs 388
- - case unseal (simplifyPushes da (mapFL_FL NameFixup renames)) ps_to_keep of
+ case unseal (simplifyPushes (mapFL_FL NameFixup renames)) ps_to_keep of
hunk ./src/Darcs/UI/Commands/Rebase.hs 493
- - let extractSingle :: FL (RebaseChange p) wX wY -> (FL (RebaseFixup (PrimOf p)) :> Named p) wX wY
+ let extractSingle :: FL (RebaseChange p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY
hunk ./src/Darcs/UI/Commands/Rebase.hs 513
- - toeditNew = fmapFL_Named (mapFL_FL fromAnonymousPrim . canonizeFL da . (injects +>+) . effect) toedit
- - case unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups))
- - $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups)
+ toeditNew =
+ fmapFL_Named
+ (mapFL_FL fromAnonymousPrim . canonizeFL da . (injects +>+) . effect)
+ toedit
+ case unseal (simplifyPushes (mapFL_FL NameFixup name_fixups))
+ $ simplifyPushes (mapFL_FL PrimFixup rest_fixups)
hunk ./src/Darcs/UI/Commands/Rebase.hs 561
- - let da = diffAlgorithm ? opts
- - do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
+ let do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
hunk ./src/Darcs/UI/Commands/Rebase.hs 563
- - do_obliterate (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs
+ do_obliterate (Fixup f :>: qs) = unseal (simplifyPush f) . do_obliterate qs
hunk ./src/Darcs/UI/Commands/Rebase.hs 566
- - unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .
- - unseal (simplifyPushes da (mapFL_FL PrimFixup (effect (patchcontents e)))) .
+ unseal (simplifyPush (NameFixup (AddName (patch2patchinfo e)))) .
+ unseal (simplifyPushes (mapFL_FL PrimFixup (patchcontents e))) .
[use pager to display 'darcs rebase log'
Ben Franksen <ben.franksen at online.de>**20200524154809
Ignore-this: de51b2db87e458550cf95a1940f80a24cefad4f2c8859fa46a3a146bb901e8762f3d8029a85e756e
] hunk ./src/Darcs/UI/Commands/Rebase.hs 96
+import Darcs.UI.External ( viewDocWith )
hunk ./src/Darcs/UI/Commands/Rebase.hs 121
- - , putDocLnWith, simplePrinters
+ , simplePrinters
hunk ./src/Darcs/UI/Commands/Rebase.hs 799
- - putDocLnWith printers logDoc
+ viewDocWith printers logDoc
[fix rebase unsuspend after rebase changes
Ben Franksen <ben.franksen at online.de>**20200523213900
Ignore-this: 19349ed0ba9ebd89e93172d3317c77ef7bebcc4352df8bab786506975fdf640f3e4b54d1d1c0c449
] hunk ./src/Darcs/UI/Commands/Rebase.hs 73
- -import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )
+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims, namedToFixups )
hunk ./src/Darcs/UI/Commands/Rebase.hs 387
+
+ -- re-add the patches that we unsuspend as fixups to the rebase state
+ case unseal (simplifyPushes $ concatFL (mapFL_FL (namedToFixups . wddPatch) ps_to_unsuspend)) ps_to_keep of
+ Sealed new_ps ->
+ -- write the tentative rebase state, since doAdd modifies it
+ -- via the call to tentativelyAddPatch
+ writeTentativeRebase _repository (Items new_ps)
hunk ./src/Darcs/UI/Commands/Rebase.hs 395
- - (_repository, renames) <- runHijackT IgnoreHijack $ doAdd _repository ps_to_unsuspend
- - case unseal (simplifyPushes (mapFL_FL NameFixup renames)) ps_to_keep of
- - Sealed new_ps -> writeTentativeRebase _repository (Items new_ps)
+ (_repository, renames) <-
+ runHijackT IgnoreHijack $ doAdd _repository ps_to_unsuspend
+ -- to push the renames, we must re-read the rebase state (doAdd modifies it)
+ Items new_rebase_items <- readTentativeRebase _repository
+ case simplifyPushes (mapFL_FL NameFixup renames) new_rebase_items of
+ Sealed final_rebase_items ->
+ writeTentativeRebase _repository (Items final_rebase_items)
[fix Darcs.Patch.Rebase.Viewing.partitionUnconflicted
Ben Franksen <ben.franksen at online.de>**20200523213708
Ignore-this: de13144cff354968c336af423009c0efc5a7f5827429104a6b0f1868946784848c4abfe1dce8cd85
] hunk ./src/Darcs/Patch/Rebase/Viewing.hs 22
- -import Darcs.Patch.Commute ( commuteFL, commuteRL )
+import Darcs.Patch.Commute ( commuteFL )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 41
+import Darcs.Patch.Permutations ( partitionFL' )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 46
- -import Darcs.Patch.Summary ( Summary(..) )
+import Darcs.Patch.Summary ( Summary(..), hasConflicts )
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 169
- -partitionUnconflicted = partitionUnconflictedAcc NilRL
- -
- -partitionUnconflictedAcc :: RepoPatch p
- - => RL (RebaseChange p) wX wY -> FL (RebaseChange p) wY wZ
- - -> (FL (RebaseChange p) :> RL (RebaseChange p)) wX wZ
- -partitionUnconflictedAcc right NilFL = NilFL :> right
- -partitionUnconflictedAcc right (p :>: ps) =
- - case commuteRL (right :> p) of
- - Just (p'@(RC NilFL _) :> right')
- - -> case partitionUnconflictedAcc right' ps of
- - left' :> right'' -> (p' :>: left') :> right''
- - _ -> partitionUnconflictedAcc (right :<: p) ps
+partitionUnconflicted ps =
+ case partitionFL' (not . hasConflicts) NilRL NilRL ps of
+ left :> middle :> right -> left :> middle +<+ right
hunk ./src/Darcs/Patch/Summary.hs 11
+ , hasConflicts
hunk ./src/Darcs/Patch/Summary.hs 60
+hasConflicts :: Summary p => p wX wY -> Bool
+hasConflicts = any isConflicted . conflictedEffect
+ where
+ isConflicted (IsC Conflicted _) = True
+ isConflicted _ = False
+
[fix amend after rebase changes
Ben Franksen <ben.franksen at online.de>**20200523214319
Ignore-this: e61e9b61389dd352091e1555c194058d82306125391e64a99d4e23ec784edc435a37d29bab505561
] hunk ./src/Darcs/UI/Commands/Amend.hs 57
- - , effect, invert, invertFL, sortCoalesceFL
+ , effect, invertFL, sortCoalesceFL
hunk ./src/Darcs/UI/Commands/Amend.hs 61
- -import Darcs.Patch.FromPrim ( fromAnonymousPrim )
hunk ./src/Darcs/UI/Commands/Amend.hs 67
+import Darcs.Patch.Rebase.Suspended ( simplifyPushes )
hunk ./src/Darcs/UI/Commands/Amend.hs 77
- - , withManualRebaseUpdate
hunk ./src/Darcs/UI/Commands/Amend.hs 85
+import Darcs.Repository.Rebase ( withTentativeRebase )
hunk ./src/Darcs/UI/Commands/Amend.hs 98
- - , nullFL, reverseRL, reverseFL, mapFL_FL
+ , nullFL, reverseRL, reverseFL
hunk ./src/Darcs/UI/Commands/Amend.hs 300
- - (_repository, (mlogf, newp)) <-
- - withManualRebaseUpdate _repository $ \_repository -> do
+ (_repository, (mlogf, newp)) <- do
hunk ./src/Darcs/UI/Commands/Amend.hs 303
+ -- Also note that tentativelyRemovePatches will push an AddName,
+ -- which we have to cancel below
hunk ./src/Darcs/UI/Commands/Amend.hs 306
- - tentativelyRemovePatches
- - _repository
- - (compress cfg)
- - NoUpdatePending
- - (oldp :>: NilFL)
+ tentativelyRemovePatches _repository (compress cfg)
+ NoUpdatePending (oldp :>: NilFL)
hunk ./src/Darcs/UI/Commands/Amend.hs 315
- - (patchSelOpts cfg)
- - (diffAlgorithm cfg)
- - (keepDate cfg)
- - (selectAuthor cfg)
- - (author cfg)
- - (patchname cfg)
- - (askLongComment cfg)
- - oldp
- - chs
- - let fixups =
- - mapFL_FL (PrimFixup . fromAnonymousPrim) (invert chs) +>+
- - NameFixup (Rename (info newp) (info oldp)) :>:
- - NilFL
+ (patchSelOpts cfg) (diffAlgorithm cfg) (keepDate cfg)
+ (selectAuthor cfg) (author cfg) (patchname cfg)
+ (askLongComment cfg) oldp chs
+ withTentativeRebase _repository _repository $
+ simplifyPushes $
+ -- cancel the DelName from tentativelyAddPatch below:
+ NameFixup (AddName (info newp)) :>:
+ NameFixup (Rename (info newp) (info oldp)) :>:
+ -- cancel the AddName from tentativelyRemovePatches above:
+ NameFixup (DelName (info oldp)) :>:
+ NilFL
hunk ./src/Darcs/UI/Commands/Amend.hs 328
- - tentativelyAddPatch
- - _repository
- - (compress cfg)
- - (verbosity cfg)
- - NoUpdatePending
- - newp
- - return (_repository, fixups, (mlogf, newp))
+ tentativelyAddPatch _repository (compress cfg) (verbosity cfg)
+ NoUpdatePending newp
+ return (_repository, (mlogf, newp))
[remove 'rebase inject' command
Ben Franksen <ben.franksen at online.de>**20200523121741
Ignore-this: 8e9db4842ebc463fbfbe414164fe17c83e7a8bf327fba92e100208d3a0ac6f06ad9f22c5b0d65fdd
With the new conflicted rebase implementation it no longer makes sense to
have this command, since all fixups will be injected anyway on unsuspend.
] hunk ./src/Darcs/UI/Commands/Rebase.hs 69
- -import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo )
+import Darcs.Patch.Named ( patchcontents, patch2patchinfo )
hunk ./src/Darcs/UI/Commands/Rebase.hs 71
- -import Darcs.Patch.FromPrim ( PrimOf, fromAnonymousPrim )
- -import Darcs.Patch.Prim ( canonizeFL )
- -import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims, namedToFixups )
+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups )
hunk ./src/Darcs/UI/Commands/Rebase.hs 76
- - ( RebaseChange(RC), rcToPia
+ ( rcToPia
hunk ./src/Darcs/UI/Commands/Rebase.hs 87
- -import Darcs.Patch.Split ( primSplitter )
hunk ./src/Darcs/UI/Commands/Rebase.hs 95
- - ( runSelection, runInvertibleSelection
- - , selectionConfig, selectionConfigGeneric, selectionConfigPrim
+ ( runSelection
+ , selectionConfig, selectionConfigGeneric
hunk ./src/Darcs/UI/Commands/Rebase.hs 153
- - , hiddenCommand inject
hunk ./src/Darcs/UI/Commands/Rebase.hs 464
- -inject :: DarcsCommand [DarcsFlag]
- -inject = DarcsCommand
- - { commandProgramName = "darcs"
- - , commandName = "inject"
- - , commandHelp = "Merge a change from the fixups of a patch into the patch itself.\n"
- - , commandDescription = "Merge a change from the fixups of a patch into the patch itself."
- - , commandPrereq = amInHashedRepository
- - , commandExtraArgs = 0
- - , commandExtraArgHelp = []
- - , commandCommand = injectCmd
- - , commandCompleteArgs = noArgs
- - , commandArgdefaults = nodefaults
- - , commandAdvancedOptions = []
- - , commandBasicOptions = odesc injectBasicOpts
- - , commandDefaults = defaultFlags injectOpts
- - , commandCheckOptions = ocheck injectOpts
- - , commandParseOptions = onormalise injectOpts
- - }
- - where
- - injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm
- - injectOpts = injectBasicOpts `withStdOpts` oid
- -
- -injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
- -injectCmd _ opts _args =
- - withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $
- - RebaseJob $
- - \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do
- - Items ps <- readTentativeRebase _repository
- -
- - let selects = toRebaseSelect ps
- -
- - -- TODO this selection doesn't need to respect dependencies
- - -- TODO we only want to select one patch: generalise withSelectedPatchFromList
- - let selection_config =
- - selectionConfigGeneric rcToPia First "inject into" (patchSelOpts True opts) Nothing
- - (chosens :> rest_selects) <- runSelection selects selection_config
- -
- - let extractSingle :: FL (RebaseChange p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY
- - extractSingle (RC fixups toedit :>: NilFL) = fixups :> toedit
- - extractSingle _ = error "You must select precisely one patch!"
- -
- - fixups :> toedit <- return $ extractSingle chosens
- -
- - name_fixups :> prim_fixups <- return $ flToNamesPrims fixups
- -
- - let prim_selection_config =
- - selectionConfigPrim
- - Last "inject" (patchSelOpts True opts)
- - (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing
- - (rest_fixups :> injects) <- runInvertibleSelection prim_fixups prim_selection_config
- -
- - when (nullFL injects) $ do
- - putStrLn "No changes selected!"
- - exitSuccess
- -
- - -- Don't bother to update patch header since unsuspend will do that later
- - let da = diffAlgorithm ? opts
- - toeditNew =
- - fmapFL_Named
- - (mapFL_FL fromAnonymousPrim . canonizeFL da . (injects +>+) . effect)
- - toedit
- - case unseal (simplifyPushes (mapFL_FL NameFixup name_fixups))
- - $ simplifyPushes (mapFL_FL PrimFixup rest_fixups)
- - $ ToEdit toeditNew :>: fromRebaseChange rest_selects of
- - Sealed new_ps -> writeTentativeRebase _repository (Items new_ps)
- - _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts)
- - return ()
- -
hunk ./src/Darcs/UI/Commands/Rebase.hs 802
- - - review existence of reify and inject commands - bit of an internals hack
+ - review existence of reify command - bit of an internals hack
hunk ./tests/rebase-new-style.sh 46
- -rebase inject
[tests/rebase-apply.sh: add extra debug logs
Ben Franksen <ben.franksen at online.de>**20200524151729
Ignore-this: 50660714dc65c89a12173b424ab926c98d8fe1162c211bbc8f2279aef88243b1c23cfb586cc6789
] hunk ./tests/rebase-apply.sh 29
+logrepo() {
+ echo "REPOSITORY:" > ../$1
+ darcs log -v --reverse --machine >> ../$1
+ echo "" >> ../$1
+ echo "REBASE:" >> ../$1
+ cat _darcs/rebase >> ../$1
+}
+
hunk ./tests/rebase-apply.sh 62
+logrepo 1-before-rebase-apply
hunk ./tests/rebase-apply.sh 64
+logrepo 2-after-rebase-apply
hunk ./tests/rebase-apply.sh 67
+logrepo 3-before-unsuspend
hunk ./tests/rebase-apply.sh 81
+logrepo 4-before-amend
hunk ./tests/rebase-apply.sh 84
+logrepo 5-after-amend
[tests/rebase-apply.sh: fix expected conflict markup
Ben Franksen <ben.franksen at online.de>**20200524151816
Ignore-this: 5d415c7e94b1b0ff719b214da9e54ef73a525de03cf84dc6650354a03ae209bdadfc6f4e4de7874d
] hunk ./tests/rebase-apply.sh 90
- -3
+1
[tests/rebase-changes.sh: fix expected log output
Ben Franksen <ben.franksen at online.de>**20200524151905
Ignore-this: 7903ac9d039d03b236e7510dbf70c211d05564c68462eb2a266ebfbd8014d2d6967e62c2eaf89dce
] hunk ./tests/rebase-changes-partial-conflict.sh 38
- -darcs rebase changes -s | grep "M ./file1"
- -darcs rebase changes -s | grep "M\! ./file2"
- -darcs rebase changes -s | grep "M ./file3"
- -darcs rebase changes -s | grep "M\! ./file4"
+cat >expected_summary <<EOF
+patch 62d309146a3f8ece13d0acdada2e79600939dfc3
+Author: tester
+Date: Sun May 24 15:20:17 CEST 2020
+ * change 3
hunk ./tests/rebase-changes-partial-conflict.sh 44
- -# this is what we expect to appear in the "conflicts" section
- -darcs rebase changes --verbose | not grep "contents1A"
- -darcs rebase changes --verbose | grep "contents2A"
- -darcs rebase changes --verbose | not grep "contents3A"
- -darcs rebase changes --verbose | grep "contents4A"
+ M ./file4 -1 +1
+ M ./file2 -1 +1
+ M ./file1 -1 +1
+ M ./file2 -1 +1
+ M ./file3 -1 +1
+ M ./file4 -1 +1
+EOF
+
+darcs rebase changes -s > summary
+
+diff -I hash -I patch -I Date: expected_summary summary
+
+cat >expected_log <<EOF
+fixup
+hash 2 d447a56957228e1eb1b3282c5a2633d45a0fdc22
+hunk ./file4 1
+-contents4A
++contents4B
+fixup
+hash 1 d447a56957228e1eb1b3282c5a2633d45a0fdc22
+hunk ./file2 1
+-contents2A
++contents2B
+patch 62d309146a3f8ece13d0acdada2e79600939dfc3
+Author: tester
+Date: Sun May 24 15:20:17 CEST 2020
+ * change 3
+hash 1 62d309146a3f8ece13d0acdada2e79600939dfc3
+hunk ./file1 1
+-contents1B
++contents1C
+hash 2 62d309146a3f8ece13d0acdada2e79600939dfc3
+hunk ./file2 1
+-contents2B
++contents2C
+hash 3 62d309146a3f8ece13d0acdada2e79600939dfc3
+hunk ./file3 1
+-contents3B
++contents3C
+hash 4 62d309146a3f8ece13d0acdada2e79600939dfc3
+hunk ./file4 1
+-contents4B
++contents4C
+EOF
+
+darcs rebase changes --verbose > log
+
+diff -I hash -I patch -I Date: expected_log log
hunk ./tests/rebase-changes.sh 34
- -darcs rebase changes | grep "change 3"
- -darcs rebase changes -s | grep "M\! ./file"
- -darcs rebase changes --verbose | grep "third"
- -# now we should see a conflict with change 2
- -# which removes the line "first"
- -darcs rebase changes --verbose | grep "first"
- -darcs rebase changes --verbose | grep "conflicts:"
+cat >expected_summary <<EOF
+patch 6ca518dac1b8c4f93a8e0a8f13d3832b0677897e
+Author: tester
+Date: Sun May 24 15:15:33 CEST 2020
+ * change 3
+
+ M ./file -2 +2
+EOF
+
+darcs rebase changes -s > summary
+
+diff -I hash -I patch -I Date: expected_summary summary
+
+cat >expected_log <<EOF
+fixup
+hash 1 55657c0dda9461a8794c4fd8cb5a5c682d665aaa
+hunk ./file 1
+-first
++second
+patch 9c2580f145f222ccc160eeb8abb408cb12fb768f
+Author: tester
+Date: Sun May 24 15:07:21 CEST 2020
+ * change 3
+hash 1 9c2580f145f222ccc160eeb8abb408cb12fb768f
+hunk ./file 1
+-second
++third
+EOF
+
+darcs rebase changes --verbose > log
+
+diff -I hash -I patch -I Date: expected_log log
[add two tests for rebase of conflicted patches
Ben Franksen <ben.franksen at online.de>**20200524151948
Ignore-this: 9dd2b99c498cc139b3b00239862be2a2f9273bb74250e54f40980d690dc47cc341d0b88ba996d4fb
] addfile ./tests/rebase-conflicting-threeeway.sh
hunk ./tests/rebase-conflicting-threeeway.sh 1
+#!/usr/bin/env bash
+
+. lib
+
+rm -rf R S T
+
+darcs init R
+cd R
+touch f
+darcs record -l f -a -m 'baseline'
+darcs clone . ../S
+darcs clone . ../T
+echo R > f
+darcs record -l f -a -m 'hunk R'
+cd ../S
+echo S > f
+darcs record -l f -a -m 'hunk S'
+cd ../T
+echo T > f
+darcs record -l f -a -m 'hunk T'
+cd ../R
+darcs pull -a --allow-conflicts ../S ../T
+# echo X > f
+# darcs record -l f -a -m 'resolve conflicts'
+cd ../S
+darcs pull -a ../R --allow-conflicts
+cd ../R
+darcs log -v > ../before_rebase
+darcs rebase suspend -a
+cp _darcs/rebase ..
+darcs rebase unsuspend -a
+darcs log -v > ../after_rebase
+cd ..
addfile ./tests/rebase-conflicting.sh
hunk ./tests/rebase-conflicting.sh 1
+#!/usr/bin/env bash
+
+. lib
+
+rm -rf R S
+
+darcs init R
+cd R
+echo R > f
+darcs record -l f -a -m 'add f in R'
+cd ..
+darcs init S
+cd S
+echo S > f
+darcs record -l f -a -m 'add f in S'
+cd ../R
+darcs pull -a --allow-conflicts ../S
+echo X > f
+darcs record -l f -a -m 'resolve conflict'
+darcs push -a ../S
+darcs log -v > ../before_rebase
+darcs rebase suspend -a
+darcs rebase unsuspend -a
+darcs log -v > ../after_rebase
+cd ..
+diff R/f S/f
[tests/rebase-keeps-deps-on-amend.sh: add extra debug logs
Ben Franksen <ben.franksen at online.de>**20200524152053
Ignore-this: 3988d763512d87d6007f70b6cd91d56b1396a52e8d94587f4d048ddb9959804c550a2569bac2e59c
] hunk ./tests/rebase-keeps-deps-on-amend.sh 29
+logrepo() {
+ echo "REPOSITORY:" > ../$1
+ darcs log -v --reverse --machine >> ../$1
+ echo "" >> ../$1
+ echo "REBASE:" >> ../$1
+ cat _darcs/rebase >> ../$1
+}
+
hunk ./tests/rebase-keeps-deps-on-amend.sh 54
+logrepo 1-before-suspend
hunk ./tests/rebase-keeps-deps-on-amend.sh 57
+logrepo 2-before-amend
hunk ./tests/rebase-keeps-deps-on-amend.sh 60
+logrepo 3-after-amend
[tests/rebase-keeps-deps-on-amend.sh: remove redundant options
Ben Franksen <ben.franksen at online.de>**20200524152202
Ignore-this: 4dbc3e28ed5fd610efbb894802bce3d4065cbb6b58a79bf9028c0c059127dfac7ef81143ec7af44b
] hunk ./tests/rebase-keeps-deps-on-amend.sh 44
- -darcs rec -am"A" --ignore-times
+darcs rec -am"A"
hunk ./tests/rebase-keeps-deps-on-amend.sh 48
- -darcs rec -am"B" --ignore-times
+darcs rec -am"B"
hunk ./tests/rebase-keeps-deps-on-amend.sh 52
- -echo 'yyy' | darcs rec -am"C" --ignore-times --ask-deps
+echo 'yyy' | darcs rec -am"C" --ask-deps
[tests/rebase-pull.sh: fix expected conflict markup
Ben Franksen <ben.franksen at online.de>**20200524152322
Ignore-this: 99773253f87686284e4efc4b08c743f1fc3d099b83c93500f072915d67eb7580a56c9dddabbb0b9
] hunk ./tests/rebase-pull.sh 76
- -3
+1
[tests/rebase-repull.sh: extend with more tests and debugging
Ben Franksen <ben.franksen at online.de>**20200524152402
Ignore-this: e99aa451f7e1d66ead593409c3913c05775af80e388db92726804f8c06d7bf62e19ed5fd9d061f17
] hunk ./tests/rebase-repull.sh 29
- -rm -rf R
+logrepo() {
+ echo "REPOSITORY:" > ../$1
+ darcs log -v --reverse --machine >> ../$1
+ echo "" >> ../$1
+ echo "REBASE:" >> ../$1
+ cat _darcs/rebase >> ../$1
+}
+
+rm -rf R R2
hunk ./tests/rebase-repull.sh 48
+logrepo 1-before-rebase-suspend
hunk ./tests/rebase-repull.sh 50
+logrepo 2-before-pull
hunk ./tests/rebase-repull.sh 52
+logrepo 3-after-pull
hunk ./tests/rebase-repull.sh 54
+logrepo 4-after-rebase-obliterate
+cd ..
+
+# now test the same but with two conflicted patches
+
+rm -rf R R1 R2
+mkdir R
+cd R
+darcs init
+echo 'wibble' > wibble
+darcs rec -lam "add wibble"
+cd ..
+
+darcs get R R1
+cd R1
+echo wobble > wibble
+echo y | darcs amend -am 'conflicting wobble'
+cd ../R
+darcs pull -a --allow-conflicts ../R1
+cd ..
+
+darcs get R R2
+cd R2
+darcs revert -a
+cd ..
+
+cd R
+logrepo 5-before-rebase-suspend
+echo 'yyy' | darcs rebase suspend
+logrepo 6-before-pull
+darcs pull -a ../R2 --allow-conflicts
+logrepo 7-after-pull
+echo yyyu | darcs rebase unsuspend
+logrepo 8-after-rebase-unsuspend
+
+# again with two conflicted patches and resolution
+
+rm -rf R R1 R2
+mkdir R
+cd R
+darcs init
+echo 'wibble' > wibble
+darcs rec -lam "add wibble"
+cd ..
+
+darcs get R R1
+cd R1
+echo wobble > wibble
+echo y | darcs amend -am 'conflicting wobble'
+cd ../R
+darcs pull -a --allow-conflicts ../R1
+echo wobble > wibble
+darcs rec -lam 'resolution'
+cd ..
+
+darcs get R R2
+
+cd R
+logrepo 5-before-rebase-suspend
+echo 'yyyy' | darcs rebase suspend
+logrepo 6-before-pull
+darcs pull -a ../R2
+logrepo 7-after-pull
+echo yyyy | darcs rebase unsuspend
+logrepo 8-after-rebase-unsuspend
[harness: disable duplicateConflictedEffect test
Ben Franksen <ben.franksen at online.de>**20200523115800
Ignore-this: b1e103093c54d1557881241fcbab74af15e2db587f2ebdbe32b81b3c4c8b285c3bdb338bc880bbe6
It is questionable whether this test makes any sense at all with the
conflicted rebase.
] hunk ./harness/Darcs/Test/Patch/Rebase.hs 4
+{-
hunk ./harness/Darcs/Test/Patch/Rebase.hs 10
+-}
hunk ./harness/Darcs/Test/Patch/Rebase.hs 13
+{-
hunk ./harness/Darcs/Test/Patch/Rebase.hs 16
+-}
hunk ./harness/Darcs/Test/Patch/Rebase.hs 19
+{-
hunk ./harness/Darcs/Test/Patch/Rebase.hs 28
+-}
hunk ./harness/Darcs/Test/Patch/Rebase.hs 30
- -testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p)) => [Test]
- -testSuite =
+testSuite :: forall p . (RepoPatch p{- , ArbitraryPrim (PrimOf p) -}) => [Test]
+testSuite = []
+{-
hunk ./harness/Darcs/Test/Patch/Rebase.hs 56
+-}
[add atomatic upgrade from rebase version "0.0"
Ben Franksen <ben.franksen at online.de>**20200525085728
Ignore-this: 7bc8c369e07226973a7418f392149fdf7a019d18f136e83a91e4ee84a3952ef5d0940f4646aa4ff3
This upgrade simply uses fromAnonymousPrim to upgrade prim fixups to patch
fixups.
] hunk ./darcs.cabal 185
+ Darcs.Patch.Rebase.Legacy.Item
hunk ./src/Darcs/Patch/Named/Wrapped.hs 131
- -instance (ReadPatch p, PatchListFormat p) => ReadPatch (ReadRebasing p) where
+instance (FromPrim p, PrimPatchBase p, ReadPatch p, PatchListFormat p) =>
+ ReadPatch (ReadRebasing p) where
adddir ./src/Darcs/Patch/Rebase/Legacy
addfile ./src/Darcs/Patch/Rebase/Legacy/Item.hs
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 1
+{-# LANGUAGE UndecidableInstances #-}
+module Darcs.Patch.Rebase.Legacy.Item
+ ( RebaseItem(..)
+ ) where
+
+import Darcs.Prelude
+
+import Darcs.Patch.Format ( PatchListFormat(..) )
+import Darcs.Patch.Named ( Named(..) )
+import Darcs.Patch.Read ( ReadPatch(..) )
+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )
+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
+import Darcs.Util.Parser ( Parser, lexString )
+import Darcs.Patch.Witnesses.Sealed
+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )
+
+import Control.Applicative ( (<|>) )
+import qualified Data.ByteString as B ( ByteString )
+import qualified Data.ByteString.Char8 as BC ( pack )
+
+-- |A single item in the rebase state consists of either
+-- a patch that is being edited, or a fixup that adjusts
+-- the context so that a subsequent patch that is being edited
+-- \"makes sense\".
+--
+-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of
+-- the patch will typically be the name the patch had before
+-- it was added to the rebase state; if it is moved back
+-- into the repository it must be given a fresh name to account
+-- for the fact that it will not necessarily have the same
+-- dependencies or content as the original patch. This is typically
+-- done by changing the @Ignore-This@ junk.
+--
+-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch
+-- is correct. Where possible, @Fixup@ changes are commuted
+-- as far as possible into the rebase state, so any remaining
+-- ones will typically cause a conflict when the @ToEdit@ patch
+-- is moved back into the repository.
+data RebaseItem p wX wY where
+ ToEdit :: Named p wX wY -> RebaseItem p wX wY
+ Fixup :: RebaseFixup (PrimOf p) wX wY -> RebaseItem p wX wY
+
+deriving instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY)
+
+instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX)
+
+instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p)
+
+-- This Read instance partly duplicates the instances for RebaseFixup, but are
+-- left this way given this code is now here only for backwards compatibility
+-- of the on-disk format and we might want to make future changes to RebaseFixup.
+instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) =>
+ ReadPatch (RebaseItem p) where
+ readPatch' =
+ mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|>
+ mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup") <|>
+ mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name")
+ where
+ readWith :: ReadPatch q => B.ByteString -> Parser (Sealed (q wX))
+ readWith str = do
+ lexString str
+ lexString (BC.pack "(")
+ res <- readPatch'
+ lexString (BC.pack ")")
+ return res
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 14
+import Darcs.Patch.FromPrim ( FromPrim, fromAnonymousPrim )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 22
- -import qualified Darcs.Patch.Rebase.Item as Item ( countToEdit, simplifyPush, simplifyPushes )
+import qualified Darcs.Patch.Rebase.Item as Item
+ ( countToEdit, simplifyPush, simplifyPushes )
+import qualified Darcs.Patch.Rebase.Legacy.Item as Legacy
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 34
- -import Control.Monad ( when )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 56
- -instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where
- - showPatch f (Items ps)
- - = blueText "rebase" <+> text "1.0" <+> blueText "{"
- - $$ vcat (mapFL (showPatch f) ps)
- - $$ blueText "}"
+instance (PatchListFormat p, ShowPatchBasic p) =>
+ ShowPatchBasic (Suspended p) where
+ showPatch f (Items ps) =
+ blueText "rebase" <+>
+ text "1.0" <+>
+ blueText "{" $$ vcat (mapFL (showPatch f) ps) $$ blueText "}"
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 63
- -instance (PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where
- - readPatch' =
- - do lexString (BC.pack "rebase")
- - version <- myLex'
- - when (version /= BC.pack "1.0") $ error $ "can't handle rebase version " ++ show version
- - (lexString (BC.pack "{}") >> return (seal (Items NilFL)))
- - <|>
- - (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}')
+instance (FromPrim p, PatchListFormat p, PrimPatchBase p, ReadPatch p) =>
+ ReadPatch (Suspended p) where
+ readPatch' = do
+ lexString (BC.pack "rebase")
+ version <- myLex'
+ case () of
+ _ | version == BC.pack "0.0"
+ ->
+ -- Note that if we have an "old-style" rebase, i.e. the first rebase
+ -- implementation in darcs, characterised by the format string
+ -- "rebase-in-progress", then only version 0.0 is possible here. On
+ -- the other hand, the more recent implementation could use any
+ -- version including 0.0.
+ let itemsToSuspended :: Sealed (FL (Legacy.RebaseItem p) wX)
+ -> Sealed (Suspended p wX)
+ itemsToSuspended (Sealed ps) = Sealed (Items (mapFL_FL fromLegacy ps))
+ fromLegacy :: Legacy.RebaseItem p wX wY -> RebaseItem p wX wY
+ fromLegacy (Legacy.ToEdit p) = ToEdit p
+ fromLegacy (Legacy.Fixup (NameFixup n)) = Fixup (NameFixup n)
+ fromLegacy (Legacy.Fixup (PrimFixup prim)) =
+ Fixup (PrimFixup (fromAnonymousPrim prim))
+ in (lexString (BC.pack "{}") >> return (seal (Items NilFL)))
+ <|>
+ (itemsToSuspended <$> bracketedFL readPatch' '{' '}')
+ | version == BC.pack "1.0" ->
+ (lexString (BC.pack "{}") >> return (seal (Items NilFL)))
+ <|>
+ (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}')
+ | otherwise -> error $ "can't handle rebase version " ++ show version
[store original patch name together with fixup
Ben Franksen <ben.franksen at online.de>**20200525180648
Ignore-this: 89521d4ad207a80de2c6fd238d4754c76ae83beec15d03b195caa6c2bd7fc4458f74abd00a47d86
This is so we can distinguish between fixups and patches inside suspended
named patches when they are content-wise equal i.e. duplicates.
] hunk ./src/Darcs/Patch/Rebase/Fixup.hs 19
+import Darcs.Patch.Info ( PatchInfo )
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 21
- -import Darcs.Patch.Invert ( Invert(..) )
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 39
- - PrimFixup :: p wX wY -> RebaseFixup p wX wY
+ PrimFixup :: PatchInfo -> p wX wY -> RebaseFixup p wX wY
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 43
- -namedToFixups (NamedP p _ contents) =
- - NameFixup (AddName p) :>: mapFL_FL PrimFixup contents
+namedToFixups (NamedP i _ contents) =
+ NameFixup (AddName i) :>: mapFL_FL (PrimFixup i) contents
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 47
- - showsPrec d (PrimFixup p) =
- - showParen (d > appPrec) $ showString "PrimFixup " . showsPrec2 (appPrec + 1) p
+ showsPrec d (PrimFixup i p) =
+ showParen (d > appPrec) $
+ showString "PrimFixup " .
+ shows i .
+ showsPrec2 (appPrec + 1) p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 53
- - showParen (d > appPrec) $ showString "NameFixup " . showsPrec2 (appPrec + 1) p
+ showParen (d > appPrec) $
+ showString "NameFixup " . showsPrec2 (appPrec + 1) p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 65
- - apply (PrimFixup p) = apply p
+ apply (PrimFixup _ p) = apply p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 67
- - unapply (PrimFixup p) = unapply p
+ unapply (PrimFixup _ p) = unapply p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 70
- -instance Invert p => Invert (RebaseFixup p) where
- - invert (PrimFixup p) = PrimFixup (invert p)
- - invert (NameFixup n) = NameFixup (invert n)
- -
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 71
- - listTouchedFiles (PrimFixup p) = listTouchedFiles p
+ listTouchedFiles (PrimFixup _ p) = listTouchedFiles p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 74
- - hunkMatches f (PrimFixup p) = hunkMatches f p
+ hunkMatches f (PrimFixup _ p) = hunkMatches f p
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 78
- - commute (PrimFixup p :> PrimFixup q) = do
+ commute (PrimFixup i p :> PrimFixup j q) = do
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 80
- - return (PrimFixup q' :> PrimFixup p')
+ return (PrimFixup j q' :> PrimFixup i p')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 86
- - commute (PrimFixup p :> NameFixup q) = do
+ commute (PrimFixup i p :> NameFixup q) = do
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 88
- - return (NameFixup q' :> PrimFixup p')
+ return (NameFixup q' :> PrimFixup i p')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 90
- - commute (NameFixup p :> PrimFixup q) = do
+ commute (NameFixup p :> PrimFixup j q) = do
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 92
- - return (PrimFixup q' :> NameFixup p')
+ return (PrimFixup j q' :> NameFixup p')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 100
- -pushFixupFixup (PrimFixup f1 :> PrimFixup f2)
+pushFixupFixup (PrimFixup i1 f1 :> PrimFixup i2 f2)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 102
- - Just (f2' :> f1') -> PrimFixup f2' :>: NilFL :> Just2 (PrimFixup f1')
- - Nothing -> PrimFixup f1 :>: PrimFixup f2 :>: NilFL :> Nothing2
+ Just (f2' :> f1') -> PrimFixup i2 f2' :>: NilFL :> Just2 (PrimFixup i1 f1')
+ Nothing -> PrimFixup i1 f1 :>: PrimFixup i2 f2 :>: NilFL :> Nothing2
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 105
- -pushFixupFixup (PrimFixup f :> NameFixup n)
+pushFixupFixup (PrimFixup i f :> NameFixup n)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 107
- - n' :> f' -> (NameFixup n' :>: NilFL) :> Just2 (PrimFixup f')
+ n' :> f' -> (NameFixup n' :>: NilFL) :> Just2 (PrimFixup i f')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 113
- -pushFixupFixup (NameFixup n :> PrimFixup f)
+pushFixupFixup (NameFixup n :> PrimFixup j f)
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 115
- - f' :> n' -> (PrimFixup f' :>: NilFL) :> Just2 (NameFixup n')
+ f' :> n' -> (PrimFixup j f' :>: NilFL) :> Just2 (NameFixup n')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 125
- -flToNamesPrims (PrimFixup p :>: fs) =
+flToNamesPrims (PrimFixup _ p :>: fs) =
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 134
- -commuteNamedFixup (p :> PrimFixup q) = do
+commuteNamedFixup (p :> PrimFixup j q) = do
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 136
- - return (PrimFixup q' :>: NilFL :> p')
+ return (PrimFixup j q' :>: NilFL :> p')
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 153
- -commuteFixupNamed (PrimFixup p :> q) = do
+commuteFixupNamed (PrimFixup i p :> q) = do
hunk ./src/Darcs/Patch/Rebase/Fixup.hs 155
- - return (q' :> PrimFixup p' :>: NilFL)
+ return (q' :> PrimFixup i p' :>: NilFL)
hunk ./src/Darcs/Patch/Rebase/Item.hs 14
- -import Darcs.Patch.Named ( Named(..), mergerIdNamed )
+import Darcs.Patch.Named ( Named(..), mergerIdNamed, patch2patchinfo )
hunk ./src/Darcs/Patch/Rebase/Item.hs 17
+import Darcs.Patch.Info ( readPatchInfo, showPatchInfo )
hunk ./src/Darcs/Patch/Rebase/Item.hs 121
- -instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where
- - showPatch f (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch f p $$ blueText ")"
- - showPatch f (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")" where
- - showPatch f (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"
+instance (PatchListFormat p, ShowPatchBasic p) =>
+ ShowPatchBasic (RebaseItem p) where
+ showPatch f (ToEdit p) =
+ blueText "rebase-toedit" <+> blueText "(" $$ showPatch f p $$ blueText ")"
+ showPatch f (Fixup (PrimFixup i p)) =
+ blueText "rebase-fixup" <+>
+ blueText "(" $$ showPatchInfo f i $$ showPatch f p $$ blueText ")"
+ showPatch f (Fixup (NameFixup p)) =
+ blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"
hunk ./src/Darcs/Patch/Rebase/Item.hs 135
- - summary (Fixup (PrimFixup p)) = plainSummary p
+ summary (Fixup (PrimFixup _ p)) = plainSummary p
hunk ./src/Darcs/Patch/Rebase/Item.hs 141
- - readPatch' = mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|>
- - mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>
- - mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name" )
- - where readWith :: forall q wX . ReadPatch q => B.ByteString -> Parser (Sealed (q wX))
- - readWith str = do lexString str
- - lexString (BC.pack "(")
- - res <- readPatch'
- - lexString (BC.pack ")")
- - return res
+ readPatch' =
+ mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") readPatch' <|>
+ mapSeal Fixup <$> readWith (BC.pack "rebase-fixup") readPrimFixup <|>
+ mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name") readPatch'
+ where
+ readPrimFixup = do
+ i <- readPatchInfo
+ Sealed p <- readPatch'
+ return (Sealed (PrimFixup i p))
+ readWith :: B.ByteString
+ -> Parser a
+ -> Parser a
+ readWith str parser = do
+ lexString str
+ lexString (BC.pack "(")
+ res <- parser
+ lexString (BC.pack ")")
+ return res
hunk ./src/Darcs/Patch/Rebase/Item.hs 183
- -removeFixup (PrimFixup p) (ToEdit q :>: qs)
- - | Just q' <- removeFromNamed p q = Sealed (ToEdit q' :>: qs)
+removeFixup (PrimFixup i p) (ToEdit q :>: qs)
+ | i == patch2patchinfo q
+ , Just q' <- removeFromNamed p q = Sealed (ToEdit q' :>: qs)
hunk ./src/Darcs/Patch/Rebase/Item.hs 189
- - case removeFixup (PrimFixup p') qs of
+ case removeFixup (PrimFixup i p') qs of
hunk ./src/Darcs/Patch/Rebase/Item.hs 191
- -removeFixup (PrimFixup p) (Fixup (PrimFixup q) :>: qs)
- - | IsEq <- p =\/= q = Sealed qs
+removeFixup (PrimFixup i p) (Fixup (PrimFixup j q) :>: qs)
+ | i == j, IsEq <- p =\/= q = Sealed qs
hunk ./src/Darcs/Patch/Rebase/Item.hs 196
- - case removeFixup (PrimFixup p') qs of
- - Sealed qs' -> Sealed (Fixup (PrimFixup q') :>: qs')
- -removeFixup (PrimFixup p) (Fixup (NameFixup q) :>: qs) =
+ case removeFixup (PrimFixup i p') qs of
+ Sealed qs' -> Sealed (Fixup (PrimFixup j q') :>: qs')
+removeFixup (PrimFixup i p) (Fixup (NameFixup q) :>: qs) =
hunk ./src/Darcs/Patch/Rebase/Item.hs 201
- - case removeFixup (PrimFixup p') qs of
+ case removeFixup (PrimFixup i p') qs of
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 1
+{-# OPTIONS_GHC -fno-cse #-}
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 4
- - ( RebaseItem(..)
+ ( readLegacyRebaseItem
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 10
- -import Darcs.Patch.Named ( Named(..) )
+import Darcs.Patch.Named ( Named(..), anonymous )
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 12
- -import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )
+import Darcs.Patch.FromPrim ( FromPrim, PrimOf )
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 14
+import Darcs.Patch.Rebase.Item ( RebaseItem(..) )
+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )
+import Darcs.Patch.Witnesses.Ordered ( FL(..) )
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 18
- -import Darcs.Patch.Witnesses.Sealed
- -import Darcs.Patch.Witnesses.Show ( Show1, Show2 )
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 22
+import System.IO.Unsafe ( unsafePerformIO )
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 24
- --- |A single item in the rebase state consists of either
- --- a patch that is being edited, or a fixup that adjusts
- --- the context so that a subsequent patch that is being edited
- --- \"makes sense\".
- ---
- --- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of
- --- the patch will typically be the name the patch had before
- --- it was added to the rebase state; if it is moved back
- --- into the repository it must be given a fresh name to account
- --- for the fact that it will not necessarily have the same
- --- dependencies or content as the original patch. This is typically
- --- done by changing the @Ignore-This@ junk.
- ---
- --- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch
- --- is correct. Where possible, @Fixup@ changes are commuted
- --- as far as possible into the rebase state, so any remaining
- --- ones will typically cause a conflict when the @ToEdit@ patch
- --- is moved back into the repository.
- -data RebaseItem p wX wY where
- - ToEdit :: Named p wX wY -> RebaseItem p wX wY
- - Fixup :: RebaseFixup (PrimOf p) wX wY -> RebaseItem p wX wY
- -
- -deriving instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY)
- -
- -instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX)
- -
- -instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p)
- -
- --- This Read instance partly duplicates the instances for RebaseFixup, but are
- --- left this way given this code is now here only for backwards compatibility
- --- of the on-disk format and we might want to make future changes to RebaseFixup.
- -instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) =>
- - ReadPatch (RebaseItem p) where
- - readPatch' =
+readLegacyRebaseItem :: (PatchListFormat p, ReadPatch p, FromPrim p, ReadPatch (PrimOf p))
+ => Parser (Sealed (RebaseItem p wX))
+readLegacyRebaseItem =
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 28
- - mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup") <|>
+ mapSeal (Fixup . anonymousPrimFixup) <$> readWith (BC.pack "rebase-fixup") <|>
hunk ./src/Darcs/Patch/Rebase/Legacy/Item.hs 30
- - where
- - readWith :: ReadPatch q => B.ByteString -> Parser (Sealed (q wX))
- - readWith str = do
- - lexString str
- - lexString (BC.pack "(")
- - res <- readPatch'
- - lexString (BC.pack ")")
- - return res
+
+readWith :: ReadPatch p => B.ByteString -> Parser (Sealed (p wX))
+readWith str = do
+ lexString str
+ lexString (BC.pack "(")
+ res <- readPatch'
+ lexString (BC.pack ")")
+ return res
+
+{-# NOINLINE anonymousPrimFixup #-}
+anonymousPrimFixup :: forall p wX wY. FromPrim p
+ => PrimOf p wX wY -> RebaseFixup p wX wY
+anonymousPrimFixup prim = unsafePerformIO $ do
+ NamedP n _ (p :>: NilFL :: FL p wX wY) <- anonymous (prim :>: NilFL)
+ return (PrimFixup n p)
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 14
- -import Darcs.Patch.FromPrim ( FromPrim, fromAnonymousPrim )
+import Darcs.Patch.FromPrim ( FromPrim )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 24
- -import qualified Darcs.Patch.Rebase.Legacy.Item as Legacy
+import Darcs.Patch.Rebase.Legacy.Item ( readLegacyRebaseItem )
hunk ./src/Darcs/Patch/Rebase/Suspended.hs 76
- - let itemsToSuspended :: Sealed (FL (Legacy.RebaseItem p) wX)
- - -> Sealed (Suspended p wX)
- - itemsToSuspended (Sealed ps) = Sealed (Items (mapFL_FL fromLegacy ps))
- - fromLegacy :: Legacy.RebaseItem p wX wY -> RebaseItem p wX wY
- - fromLegacy (Legacy.ToEdit p) = ToEdit p
- - fromLegacy (Legacy.Fixup (NameFixup n)) = Fixup (NameFixup n)
- - fromLegacy (Legacy.Fixup (PrimFixup prim)) =
- - Fixup (PrimFixup (fromAnonymousPrim prim))
- - in (lexString (BC.pack "{}") >> return (seal (Items NilFL)))
- - <|>
- - (itemsToSuspended <$> bracketedFL readPatch' '{' '}')
+ (lexString (BC.pack "{}") >> return (seal (Items NilFL)))
+ <|>
+ (unseal (Sealed . Items) <$> bracketedFL readLegacyRebaseItem '{' '}')
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 113
- - showFixup (PrimFixup p) = blueText "fixup" $$ showPatch ForDisplay p
+ showFixup (PrimFixup _ p) = blueText "fixup" $$ showPatch ForDisplay p
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 271
- -injects ((PrimFixup p :>: ps) :> qs) =
+injects ((PrimFixup i p :>: ps) :> qs) =
hunk ./src/Darcs/Patch/Rebase/Viewing.hs 275
- - qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')
+ qs'' :> p' -> qs'' :> (mapFL_FL (PrimFixup i) p' +>+ ps')
hunk ./src/Darcs/UI/Commands/Rebase.hs 504
- - do_obliterate (ToEdit e :>: qs) = -- since Named doesn't have any witness context for the
- - -- patch names, the AddName here will be inferred to be wX wX
- - unseal (simplifyPush (NameFixup (AddName (patch2patchinfo e)))) .
- - unseal (simplifyPushes (mapFL_FL PrimFixup (patchcontents e))) .
- - do_obliterate qs
+ do_obliterate (ToEdit e :>: qs) =
+ -- since Named doesn't have any witness context for the
+ -- patch names, the AddName here will be inferred to be wX wX
+ let i = patch2patchinfo e in
+ unseal (simplifyPush (NameFixup (AddName i))) .
+ unseal (simplifyPushes (mapFL_FL (PrimFixup i) (patchcontents e))) .
+ do_obliterate qs
Context:
[add a basic test for darcs rebase changes
Ganesh Sittampalam <ganesh at earth.li>**20190903111745
Ignore-this: e205c3716129b87c0944512ddfb9b033
]
[add another test for rebase changes
Ganesh Sittampalam <ganesh at earth.li>**20190904144658
Ignore-this: ed590476e90397a5166450e59dcfaabf
This checks that if some parts of the patch are in conflict
and some aren't, that this is reported properly.
]
[document why we commute in RebaseChange.conflictedEffect
Ganesh Sittampalam <ganesh at earth.li>**20190920145119
Ignore-this: 1c9600b40539dec22e61abc99b5dcdee
]
[in D.P.Rebase.Viewing replace complicated constraints with RepoPatch
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 34818143868c4eae40967b4494211f1e960da474de2d3325ca4e9958f43866c1e6f1f007fd2fea24
]
[remove Invert from RepoPatch constraint synonym
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 41d2353fb0edd53d99a540d97fdc5b5b95ed37dbc044887afea0faec1697e1a153195cf93e1155
This also disables tests for inverses of RepoPatches and fixes the
permutivity test to no longer require it.
]
[annotate: push inversion down to the prim level
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: cd2c6896b17d531e2c52e817aac241471a19e005372181d4b9061a7b2bfa8f986f123ba9382432d8
We must take care that we call the annotate method only on inverted prims
and that we traverse the history (of prims) in reverse order. To avoid
mistakes when defining instances (outside of Darcs.Patch.Annotate), we now
use a default method with a default signature.
]
[get rid of the last Invert constraints for RepoPatch in rebase
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 6abd9b5c4e7f13998f83ad7b427f2a9d8b297850b8f051c0c4932181ef79551b918b70f134890120
This is done by changing the forceCommute implementation to do inversion on
the underlying prims.
]
[remove Apply and PrimPatchBase instances in D.P.Rebase.Suspended
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 76536ac18b64d7bbeec9211dde29fefa39c4989f28f8e786ceede7779d70caf8d11fb79cb47bf3b1
The Apply instance was used only for legacy support in D.P.Named.Wrapped and
we can as well declare the apply and unapply methods there. A comment
explains the definitions (which just return ()) in terms of the witnesses
for the RebaseP constructor.
]
[rename data types and functions that support patch selection
Ben Franksen <ben.franksen at online.de>**20190920150325
Ignore-this: abada7d67d7141e95e1307bb0671be2104587133400f925d02551dd66ebf53aa3830668b6699c617
This renames *Context to *Config except for InteractiveSelectionContext
which is renamed to InteractiveSelectionState.
]
[rename patches_context to selection_context in rebase command
Ben Franksen <ben.franksen at online.de>**20190911094047
Ignore-this: 31cec014fd5757cf98687616b5840a68762dce550f0b863f226e97ec487f8903ee381f0a60eff13f
]
[remove embedded PrimPatch constraint from PrimFixup
Ganesh Sittampalam <ganesh at earth.li>**20190927134917
Ignore-this: 3a5fc8182798fe67e8749d0c05e96e71
I think it dates from a time when the encoding of rebase
required it to be there, but it's not needed any more and
we can just put constraints at use sites instead.
]
[get rid of the PrimPatchBase superclass for Summary
Ganesh Sittampalam <ganesh at earth.li>**20190927122945
Ignore-this: c208e4a4029f00a0a01fcfc71966fada
It sort of makes sense in theory, especially given that
the type of conflictedEffect mentions PrimOf, but in
practice it infects instances in unpleasant ways.
]
[unify RebaseChange and RebaseSelect
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 1a68ed05992b8a9e72f6ebdc99fcf1268541a0fc1755aa0516252d9cf3575ac0296560d471a345dc
]
[re-write Darcs.Patch.Bundle using Darcs.Util.Parser
Ben Franksen <ben.franksen at online.de>**20190902202035
Ignore-this: 1c60e07d0a1752ff6ef1db0a27a975683b9f9f5241eef933e7b486a176fce4108c8a9c4ab3c53238
This does not delete any of the old code yet. It merely renames the old
parseBundle to parseBundleOld. The old code will be deleted in a later
patch. It also doesn't re-implement scanContextFile yet.
]
[remove bogus ReadPatch instances for RebaseSelect and RebaseChange
Ben Franksen <ben.franksen at online.de>**20190910081742
Ignore-this: 27d4e8c0d4886e4b4b1d4a031acf4c9b0f3cb395b33aaf1daea81a8d52bb35816f4cd3557663cbba
]
[cleanups in log command
Ben Franksen <ben.franksen at online.de>**20190912085841
Ignore-this: beb145f355e35b98ecfcc839d9ea393cf83142098ae47fb647d5df1ac43b7aa847031601e9cc0204
]
[simplify ArbitraryState instances
Ganesh Sittampalam <ganesh at earth.li>**20200126123527
Ignore-this: ce0845ca944d12f9f4736fde08b5b854
]
[use NoImplicitPrelude for test harness
Ganesh Sittampalam <ganesh at earth.li>**20200126082637
Ignore-this: 379a4025d6db9de6c02c1c2c0f23ba62
]
[add ArbitraryState instance for Named
Ganesh Sittampalam <ganesh at earth.li>**20200127225640
Ignore-this: 362778cb63746d15d1fb97334f4d6c29
]
[generalize sequence generation
Ganesh Sittampalam <ganesh at earth.li>**20200127225949
Ignore-this: 990b349ed7d9501121761f109d4a2594
]
[add combineTestResults utility
Ganesh Sittampalam <ganesh at earth.li>**20200129072310
Ignore-this: f408c4017523a27cf65441256d47a4a6
]
[update darcs-test => darcs discovery for recent cabal behaviour
Ganesh Sittampalam <ganesh at earth.li>**20200126131607
Ignore-this: 71130489b95b1805d3debf87c4434002
]
[use commuteFixupNamed in pushFixupItem
Ganesh Sittampalam <ganesh at earth.li>**20190927203804
Ignore-this: 7d9abaa2d373cede67ffc54e9af4fd46
]
[move logic for pushing past fixups into D.P.R.Fixup
Ganesh Sittampalam <ganesh at earth.li>**20190927195020
Ignore-this: bfe533e9de0031740d05ffc6d5303feb
]
[move logic for pushing prim fixups to D.P.R.Fixup
Ganesh Sittampalam <ganesh at earth.li>**20190927194003
Ignore-this: 5d2fbddf774748515012af08d3c9f0ef
]
[move logic for pushing name fixups to D.P.R.Name
Ganesh Sittampalam <ganesh at earth.li>**20190927193208
Ignore-this: 42cc078467d8da76d005fabe8b9aec7f
]
[document the unsafety of named/unnamed commute operations
Ganesh Sittampalam <ganesh at earth.li>**20190927124801
Ignore-this: a67f75c78d9ede53bdfa565a9372bf15
Also move commuterIdNamed/commuterNamedId to D.P.R.Name, so
it's closer to the other unsafe operations and less likely
to be misused.
]
[remove instances of CommuteNoConflicts for FL, RL, and Named
Ben Franksen <ben.franksen at online.de>**20190919210733
Ignore-this: de9bdd18108729e6ed065c757b0322964137258408792f244e07a2b904ae0603d8213461efb425f
]
[add Maybe2 type
Ganesh Sittampalam <ganesh at earth.li>**20190927193201
Ignore-this: a015f671694b5144cbed587a2bc43326
]
[reorder cases in pushFixupItem
Ganesh Sittampalam <ganesh at earth.li>**20190927194140
Ignore-this: a515ca54ca4a754dc8e6c42396cfe92c
Just to make it easier to see how connected logic can be
extracted to a separate function.
]
[reuse commuteNameNamed to push RebaseName through ToEdit
Ganesh Sittampalam <ganesh at earth.li>**20190927192122
Ignore-this: 4565aacdcb7fe07cac3af70fc17859cb
A commute is the natural way of implementing this operation
and following the previous refactors the logic was identical
]
[use StandaloneDeriving for some Show instances
Ganesh Sittampalam <ganesh at earth.li>**20190902221900
Ignore-this: 8ab9c2769f4f3b5610c0ab1413347605
This is possible in cases where all the directly included
patches are concrete types rather than type variables.
For example it works for
data Foo p wX wY where
Foo :: Named p wX wY -> Foo p wX wY
but not for
data Foo p wX wY where
Foo :: p wX wY -> Foo p wX wY
]
[drop redundant case in pushFixupItem
Ganesh Sittampalam <ganesh at earth.li>**20190927191906
Ignore-this: 72ce0755f09135949832cdfc121d17a8
]
[refactor simplifyPush
Ganesh Sittampalam <ganesh at earth.li>**20190927191509
Ignore-this: 4cfb7779be8faa2037c9564462602ab4
This patch introduces a general concept of pushing 'fixups'
past 'items', and uses it to implement simplifyPush.
This provides a framework for modularizing the logic in
subsequent patches.
]
[rename D.P.Rebase.Container to D.P.Rebase.Suspended
Ganesh Sittampalam <ganesh at earth.li>**20190914153826
Ignore-this: 6d8e0781683f4d6b6f242a1aca3cdd0f
The module primarily contains the Suspended type and code
to manipulate it.
]
[remove Check and Repair instances in D.P.Rebase.Suspended and D.P.Rebase.Item
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 6fa73504abd2c4770d64276031bfdaf12ac9aefb7c37736362b7d6ec1bc5250c0c4ad18732c8c47f
These were only needed while we mixed the rebase patch with normal patches.
]
[RebaseFixup take a prim as type argument, not a RepoPatch
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 67c29ae73d63aa6c0347bb01cb3fb548d9509d6128757da3d5e55d6263d6c202f48822dd3586a036
]
[remove patch type parameter to RebaseName
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: 630b06b6ccb86f21992daf8f6371e89636a18fef9832b607ba084d971491b97a36e3c7fa0cca671f
Also remove its Apply and PrimPatchBase instances.
]
[reduce the Show1/Show2 boilerplate with DefaultSignatures
Ganesh Sittampalam <ganesh at earth.li>**20190902130857
Ignore-this: ef867619eda2321368d1a6b2d5763aab
]
[eliminate Invert instances for Named, WrappedNamed, and PatchInfoAnd
Ben Franksen <ben.franksen at online.de>**20190919164037
Ignore-this: 4e554c70104c989f300cb36a846c406caf384856c96d1012e3170b066c161f13c2bb6860c8265457
]
[remove CommuteNoConflicts from RepoPatch
Ben Franksen <ben.franksen at online.de>**20190919164038
Ignore-this: b10430ecf5311cf6f9afe67281adf63c6370b2011c9d0e6eb94d807f72e47eed178c101f78570c60
]
[replace CommuteNoConflicts with CleanMerge for prim patch types
Ben Franksen <ben.franksen at online.de>**20190919164037
Ignore-this: 797a05625580c7c277159ad6032779a61e7e3c80816b747ab4008d757d74d2b369656f19b9420aa0
As a logical consequence this moves the definition of mergeList from
D.P.CommuteNoConflicts to D.P.Merge. We also explicitly call error in
definitions of cleanMerge and merge if the patch type has an Ident instance
and we try to merge two identical patches, since this is an undefined
operation.
]
[use cleanMerge to implement partitionConflictingFL
Ben Franksen <ben.franksen at online.de>**20190919164037
Ignore-this: f96859e6e37f5045f95a66700d65ae01e1ec4fedea4eb40df58842d75f35e6be508a92822919dba4
In order to simplify this change, it no longer takes a commuter as argument
but only works with plain FLs. This necessitates an upstream change to
filterOutConflicts, which while (we're at it) now gets the repositoiry
argument first, like all similar functions.
]
[fix lazy reading of inventories for apply command
Ben Franksen <ben.franksen at online.de>**20190914180221
Ignore-this: cfae5beaaf8687f3184852a7cb681521c39183daeb1941f85462bfd1b325220103d9b159f74dafc7
This was broken by checking availability of patches to be applied in a
complicated and inefficient way, which as a side-effect reads all local
inventories in our history.
]
[fix interpretation of bundles as patchsets
Ben Franksen <ben.franksen at online.de>**20190901131900
Ignore-this: 58d5603379eb21531c461e8838782a6bc9a8fcca9a7904a0d6a8bec33c420b67be6ded7f12b27847
We previously created invalid patchsets when a tag was present in the
context of a bundle. This worked (sort of) due to laziness but only if we
actually have that tag in our repo. If we don't then this rather dirty hack
interprets the bundle in a wrong context, i.e. Origin. Depending on how
findCommonAndUncommon is implemented we either get immediate errors ("cannot
commute common patches") or it hangs indefinitely trying to perform huge
amounts of bugus commutes of patches that aren't in their rightful context.
The same bug is still present in scanContextFile.
]
[add class CleanMerge & make it super class of Merge
Ben Franksen <ben.franksen at online.de>**20190919164037
Ignore-this: 57e6cec77040c30342bfa0958009b7324dba5ffef0b7233d322d95ba303611777761da455ac8187d
This does not yet replace CommuteNoConflicts. Instead, instances for
CleanMerge are, for now, defined in terms of mergeNoConflicts.
]
[use showPatch ForStorage in V3 error messages
Ben Franksen <ben.franksen at online.de>**20190901200334
Ignore-this: bfe50cc9dddf0f58bd2256f84220419c7da06685d5e23e24b513e704ba1bb763e6c8ea92afdc52d2
]
[remove lots of redundant constraints
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: e28236636e10b3110e59361106bdbeeba9c6f24d69af6e0ffdeec0f0afa2f23fa74fc335fc11245a
]
[remove superclass Commute from class Merge
Ben Franksen <ben.franksen at online.de>**20190910100155
Ignore-this: 7e6a752b226cbe930df0519e7a8ab63e80a02dc539e44e04ccb54e426ff3ee4a85c4b27b19220019
]
[Invertible: allow showPatch etc of Rev patches
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: 392d0f4a4e5222b76dc0c22d1ddcbb0d4ff4dad2de874164879a26532e2c3a77515554ab39dc9261
Instead of calling error for Rev patches, requiring that the calling code
first re-inverts the patch, we now do that ourselves. This means a Rev patch
is shown in exactly the same way as a Fwd patch. This removes the need for
reInvert in Darcs.UI.SelectPatches.
]
[possible fix for D.UI.SelectChanges.selected
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: 9fc482a1070d243f41ab1d2bb5b764f71de9258e27d99bb40b85fff7b428a0a82fdcc33c8c19798e
This makes it actually do what the docs claim it does. I am not sure this is
the correct behavior, though. It also renames it to getSelected to make its
easier to see where it is used, since the word 'selected' appears in lots of
places in this module, but getSelected is used only in printSelected.
]
[rename repr to reInvert and fix its haddocks
Ben Franksen <ben.franksen at online.de>**20190830081513
Ignore-this: 60877d2cf753e7bce24bb1cccbbe92ffabd5483c532104bc1642366516c0b5df28844d87f582ab56
]
[remove reverse constructors from RebaseSelect and RebaseChange
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: c789b18be7b8e30590578aa59909f34f64afdb9a1bc967108609940d0f680fa2d76363c90da1e9e0
]
[rewrite Summary RebaseChange to avoid force-commute
Ganesh Sittampalam <ganesh at earth.li>**20190911134024
Ignore-this: 65e0c112000c4d3a1025ef3d211ed0e6
]
[simplify instance Summary RebaseChange
Ganesh Sittampalam <ganesh at earth.li>**20190903140534
Ignore-this: a5f0306c4213dcd701fb993f54e92e84
I'm not sure why it was so complicated before. Perhaps
changeAsMerge was used elsewhere at some point.
Also removed the comment about resolveConflicts which
doesn't make much sense now.
]
[use Invertible when calling lookTouch in log command
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: 617804a94451acd6261c3a0ed6edc977d2d36c73c634547316909c6a5129480ea4a06e88d00fb717
We call lookTouch with the patches inverted. To get rid of the Invert
constraint, we wrap the patch as an Invertible patch.
]
[use Invertible to generalize runSelection
Ben Franksen <ben.franksen at online.de>**20190919164036
Ignore-this: bfcc3d4ab562293cf8c7bc66a0d11e6f006920d1d2fd920377c97784686249928227adc7fbb77d45
The new runSelection no longer requires an Invert instance for the patches.
This is done by wrapping them internally with Invertible. We keep the old
function under the new name runInvertibleSelection so we can use it for
selecting prims, since these are naturally invertible and we cannot and will
not use Splitters with wrapped Invertible patches.
]
[matching a patch should be invariant under inversion
Ben Franksen <ben.franksen at online.de>**20190830080459
Ignore-this: a7321c90ead98c2d1dea84b7c2752a66c159531c2d4e2034406fdca5c2be9448b3285b846b3de41b
This adds a property (only in the haddocks) to D.P.Match.matchAPatch and
removes re-inversion of patches when we apply a match criterion from
D.UI.SelectChanges.
]
[add Darcs.Patch.Invertible
Ben Franksen <ben.franksen at online.de>**20190919164026
Ignore-this: 40fd44bd46e5630779a3ecebc028a33c1147785ab56dff6d0b48bc2de34cfb75bfd817a7fdcb6b3b
This is a wrapper type to make an arbitrary patch type formally invertible.
We define only instances that will be needed to statisfy Invert constraints
that are currently required in the Repository and UI subsystem. Some of the
class methods defined for Invertible assume the patch is actually positive.
]
[re-export all imported classes (with members) from Darcs.Patch.RepoPatch
Ben Franksen <ben.franksen at online.de>**20190829163918
Ignore-this: 25f54fe286b4efb9ae5bfb5d74bf47d94c263d06f762a26bda820efb7f44b1374cc8796efadbaebc
]
[turn RepoPatch into a constraint synonym
Ben Franksen <ben.franksen at online.de>**20190829162443
Ignore-this: 3925585e444f26e1b238e5a0df41e6aad5e9983bcce38194d0f8eb5c4bd6398ebed934ce6e95ffec
This has a lot of advantages wrt maintenance and gets us rid of a few orphan
instances. Also included a few minor cleanups in Darcs.Patch.RepoPatch.
]
[add unapply method to class Apply
Ben Franksen <ben.franksen at online.de>**20190919164009
Ignore-this: 831f51055ca373b7d41be78e6c582dd68cf09d6c221a63a901417e8f8c4df7bdc5bda832dce6eea1
The idea here is to allow to "inverse apply" a patch without that patch
necessarily having an Invert instance.
]
[introduce PrimWithName and make NamedPrim a type synonym
Ganesh Sittampalam <ganesh at earth.li>**20190827114448
Ignore-this: 934632425eaa3bc82e5769dbee7549a9
]
[Refactor the commute implementation for NamedPrims
Ganesh Sittampalam <ganesh at earth.li>**20190827113620
Ignore-this: b1aabe8d5b3340a8a65a636460710dd8
It now just relies on the Ident class instead of the internals.
This also distinguishes a case that ought to be an internal error,
but the unit tests seem to rely on it, so this is left as a
TODO for now.
]
[remove Invert constraint from Matchable and MatchableRP
Ben Franksen <ben.franksen at online.de>**20190830221922
Ignore-this: e87f1de33bae746920f91cd1fa065215918ea9ee74916ff4c4b7775e93d486ff7eed15c0464a8a1e
This means we need to add it to a a few function that actually require it.
We do this as a preparation for eventually removing Invert instances from
all the higher level patch types.
]
[TAG 2.15.2
Ganesh Sittampalam <ganesh at earth.li>**20190916154842
Ignore-this: 49a3b59b9fd79ac55ad4e54388f88b77
]
Patch bundle hash:
9e8530eb8b7984686c8b324ab12861f87f694bba
-----BEGIN PGP SIGNATURE-----
iHUEAREIAB0WIQS1sLTEOCbYp4iyltnTbkUxbljMlwUCXswnbQAKCRDTbkUxbljM
l3x+AQDmAZv8PCjQovLlbZ7518ZZTNmOrv0qQ3gjvXgwA+rHrAEAh/Y2vnQtj+O9
wFLMMiQcO6fuxZVuqYQa1IxRAZYIKAU=
=qUXD
-----END PGP SIGNATURE-----
More information about the darcs-devel
mailing list