q4c12-twofinger 0.0.0.2 → 0.1

raw patch · 5 files changed

+337/−210 lines, 5 filesdep +tastydep +tasty-quickcheckdep −QuickCheckdep −template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty, tasty-quickcheck

Dependencies removed: QuickCheck, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +6/−0
• q4c12-twofinger.cabal +21/−12
• src/Q4C12/TwoFinger.hs +4/−25
• src/Q4C12/TwoFinger/Internal.hs +0/−173
• test/Properties.hs +306/−0

@@ -1,3 +1,9 @@+q4c12-twofinger 0.1 (2018-01-04)+================================++* Packaging: list `CHANGELOG.markdown` and `README.markdown` as `extra-doc-files`, rather than `extra-source-files`.+* Drop the `QuickCheck` dependency from the library. Move the property tests out of haddocks and into the testsuite.+ q4c12-twofinger 0.0.0.2 (2017-12-08) ==================================== 

@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack ----- hash: ee28f4558151511959af58b3246f5e92eff0db31bede2ae44ebfe4721ab36575+-- hash: cfaafc91f91a1d5bd7d0f03ffc8396161daf405cceb049464062797076e523d8  name:           q4c12-twofinger-version:        0.0.0.2+version:        0.1 synopsis:       Efficient alternating finger trees description:    This package provides efficient alternating sequences based on finger trees. These can represent sequences made up of two types of element, @e@ and @a@  where two of the same type of element cannot follow each other directly.                 .@@ -22,9 +22,9 @@ license:        BSD2 license-file:   LICENSE.BSD2 build-type:     Custom-cabal-version:  >= 1.10+cabal-version:  >= 1.24 -extra-source-files:+extra-doc-files:     CHANGELOG.markdown     README.markdown @@ -47,8 +47,7 @@   default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators   ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations   build-depends:-      QuickCheck >=2.10.1 && <2.11-    , base >=4.9.1.0 && <4.11+      base >=4.9.1.0 && <4.11     , deepseq >=1.4.3.0 && <1.5     , semigroupoids >=5.2.1 && <5.3     , streams >=3.3 && <3.4@@ -60,18 +59,28 @@ test-suite doctests   type: exitcode-stdio-1.0   main-is: Doctest.hs-  other-modules:-      Paths_q4c12_twofinger   hs-source-dirs:       test   default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators   ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-missing-import-lists -Wno-missing-home-modules   build-depends:-      QuickCheck >=2.10.1 && <2.11-    , base >=4.9.1.0 && <4.11+      base >=4.9.1.0 && <4.11     , doctest >=0.11.4 && <0.14     , lens >=4.15.4 && <4.16     , q4c12-twofinger     , streams >=3.3 && <3.4-    , template-haskell+  default-language: Haskell2010++test-suite properties+  type: exitcode-stdio-1.0+  main-is: Properties.hs+  hs-source-dirs:+      test+  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators+  ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations+  build-depends:+      base >=4.9.1.0 && <4.11+    , q4c12-twofinger+    , tasty >=0.12.0.1 && <0.13+    , tasty-quickcheck >=0.9.1 && <0.10   default-language: Haskell2010

@@ -50,6 +50,10 @@ -- -- This package's alternating finger trees are not annotated with -- sizes as described in section 4 of the paper.+--+-- Many of the functions in this package follow laws, which are not+-- documented inline. [tests/Properties.hs](https://github.com/quasicomputational/mega/blob/master/packages/twofinger/test/Properties.hs)+--is an  automatically-tested QuickCheck suite of properties. module Q4C12.TwoFinger   ( -- * TwoFingerOddA     TwoFingerOddA,@@ -126,28 +130,3 @@     infiniteOddA, infiniteOddE,     infiniteEvenA, infiniteEvenE   )---- $setup--- >>> import Q4C12.TwoFinger.Internal (AnyOddA (AnyOddA), AnyOddE (AnyOddE), AnyEvenA (AnyEvenA), AnyEvenE (AnyEvenE))--- >>> import Data.Semigroup ((<>))---- $monoid_action_properties--- prop> \(AnyOddA a) (AnyOddA b) (AnyEvenE c) -> appendOddAEvenE (a <> b) c == a <> appendOddAEvenE b c--- prop> \(AnyOddA a) (AnyOddE b) (AnyOddA c) -> appendEvenAOddA (appendOddAOddE a b) c == appendOddAEvenE a (appendOddEOddA b c)--- prop> \(AnyOddA a) (AnyOddE b) (AnyEvenA c) -> appendOddAOddE a (appendOddEEvenA b c) == appendOddAOddE a b <> c--- prop> \(AnyOddA a) (AnyEvenE b) (AnyOddE c) -> appendOddAOddE a (appendEvenEOddE b c) == appendOddAOddE (appendOddAEvenE a b) c--- prop> \(AnyOddA a) (AnyEvenE b) (AnyEvenE c) -> appendOddAEvenE a (b <> c) == appendOddAEvenE (appendOddAEvenE a b) c------ prop> \(AnyOddE a) (AnyOddA b) (AnyOddE c) -> appendOddEEvenA a (appendOddAOddE b c) == appendEvenEOddE (appendOddEOddA a b) c--- prop> \(AnyOddE a) (AnyOddA b) (AnyEvenE c) -> appendOddEOddA a (appendOddAEvenE b c) == appendOddEOddA a b <> c --- prop> \(AnyOddE a) (AnyEvenA b) (AnyOddA c) -> appendOddEOddA a (appendEvenAOddA b c) == appendOddEOddA (appendOddEEvenA a b) c--- prop> \(AnyOddE a) (AnyEvenA b) (AnyEvenA c) -> appendOddEEvenA a (b <> c) == appendOddEEvenA (appendOddEEvenA a b) c------ prop> \(AnyEvenA a) (AnyOddA b) (AnyOddA c) -> appendEvenAOddA a (b <> c) == appendEvenAOddA a b <> c--- prop> \(AnyEvenA a) (AnyOddA b) (AnyOddE c) -> appendOddAOddE (appendEvenAOddA a b) c == a <> appendOddAOddE b c--- prop> \(AnyEvenA a) (AnyOddA b) (AnyEvenE c) -> appendOddAEvenE (appendEvenAOddA a b) c == appendEvenAOddA a (appendOddAEvenE b c)--- prop> \(AnyEvenA a) (AnyEvenA b) (AnyOddA c) -> appendEvenAOddA (a <> b) c == appendEvenAOddA a (appendEvenAOddA b c)------ prop> \(AnyEvenE a) (AnyOddE b) (AnyOddA c) -> appendOddEOddA (appendEvenEOddE a b) c == a <> appendOddEOddA b c--- prop> \(AnyEvenE a) (AnyOddE b) (AnyEvenA c) -> appendOddEEvenA (appendEvenEOddE a b) c == appendEvenEOddE a (appendOddEEvenA b c)--- prop> \(AnyEvenE a) (AnyEvenE b) (AnyOddE c) -> appendEvenEOddE (a <> b) c == appendEvenEOddE a (appendEvenEOddE b c)

@@ -44,8 +44,6 @@ import qualified Data.Stream.Infinite as Stream import Data.Traversable (foldMapDefault, fmapDefault) import GHC.Generics (Generic)-import Test.QuickCheck (Gen)-import qualified Test.QuickCheck as QC  -- $setup -- >>> import Data.List (unfoldr)@@ -62,8 +60,6 @@  --TODO: Consider exporting bits and pieces from, e.g., Q4C12.TwoFinger.EvenA, without the flavour-identifying suffix, to allow qualified import. ---TODO: The prop> lines are very long due to a doctest limiation: https://github.com/sol/doctest/issues/131. When this is fixed, I should make those reasonable.- --TODO: the issue with the mathy haddocks is that double-clicking on a paragraph with one of them in them won't select the whole paragraph.  --TODO: the tuples are annoying. Consider moving to HLists.@@ -513,8 +509,6 @@   (Just (tree', e), a) -> Right (tree', (e, a))  -- | \(O(\log n)\) worst case. Inverse: 'halfunconsEvenE'------ prop> \e (AnyOddA as) -> halfunconsEvenE (halfconsOddA e as) == Just (e, as) halfconsOddA :: e -> TwoFingerOddA e a -> TwoFingerEvenE e a halfconsOddA e (EmptyOddA a) = SingleEvenE e a halfconsOddA e (SingleOddA a1 e1 a2) =@@ -524,8 +518,6 @@   Left (pr', a', node) -> DeepEvenE pr' (consOddA a' node m) sf a1  -- | \(O(\log n)\) worst case. Inverse: 'halfunsnocEvenA'------ prop> \(AnyOddA as) e -> halfunsnocEvenA (halfsnocOddA as e) == Just (as, e) halfsnocOddA :: TwoFingerOddA e a -> e -> TwoFingerEvenA e a halfsnocOddA (EmptyOddA a) e = SingleEvenA a e halfsnocOddA (SingleOddA a e1 a1) e2 =@@ -535,16 +527,12 @@   Left (node, a', sf') -> DeepEvenA a0 pr (snocOddA m node a') sf'  -- | \(O(1)\) worst case. Inverse: 'halfconsEvenE'------ prop> \(AnyOddA as) -> as == uncurry halfconsEvenE (halfunconsOddA as) halfunconsOddA :: TwoFingerOddA e a -> (a, TwoFingerEvenE e a) halfunconsOddA (EmptyOddA a) = (a, EmptyEvenE) halfunconsOddA (SingleOddA a e1 a1) = (a, SingleEvenE e1 a1) halfunconsOddA (DeepOddA a0 pr m sf a1) = (a0, DeepEvenE pr m sf a1)  -- | \(O(1)\) worst case. Inverse: 'halfsnocOddA'------ prop> \(AnyOddA as) -> as == uncurry halfsnocEvenA (halfunsnocOddA as) halfunsnocOddA :: TwoFingerOddA e a -> (TwoFingerEvenA e a, a) halfunsnocOddA (EmptyOddA a) = (EmptyEvenA, a) halfunsnocOddA (SingleOddA a1 e1 a2) = (SingleEvenA a1 e1, a2)@@ -568,22 +556,16 @@   (Just (tree', a), e) -> Right (tree', (a, e))  -- | \(O(1)\) worst case. Inverse: 'halfunconsEvenA'------ prop> \a (AnyOddE as) -> halfunconsEvenA (halfconsOddE a as) == Just (a, as) halfconsOddE :: a -> TwoFingerOddE e a -> TwoFingerEvenA e a halfconsOddE a (SingleOddE e) = SingleEvenA a e halfconsOddE a (DeepOddE pr m sf) = DeepEvenA a pr m sf  -- | \(O(1)\) worst case. Inverse: 'halfunsnocEvenE'------ prop> \(AnyOddE as) a -> halfunsnocEvenE (halfsnocOddE as a) == Just (as, a) halfsnocOddE :: TwoFingerOddE e a -> a -> TwoFingerEvenE e a halfsnocOddE (SingleOddE e) a = SingleEvenE e a halfsnocOddE (DeepOddE pr m sf) a = DeepEvenE pr m sf a  -- | \(O(\log n)\) worst case. Inverse: 'halfconsEvenA'------ prop> \(AnyOddE as) -> as == uncurry halfconsEvenA (halfunconsOddE as) halfunconsOddE :: TwoFingerOddE e a -> (e, TwoFingerEvenA e a) halfunconsOddE (SingleOddE e) = (e, EmptyEvenA) halfunconsOddE (DeepOddE pr m sf) = case digitUncons pr of@@ -591,8 +573,6 @@   (e, Just (a, pr')) -> (e, DeepEvenA a pr' m sf)  -- | \(O(\log n)\) worst case. Inverse: 'halfsnocEvenE'------ prop> \(AnyOddE as) -> as == uncurry halfsnocEvenE (halfunsnocOddE as) halfunsnocOddE :: TwoFingerOddE e a -> (TwoFingerEvenE e a, e) halfunsnocOddE (SingleOddE e) = (EmptyEvenE, e) halfunsnocOddE (DeepOddE pr m sf) = case digitUnsnoc sf of@@ -617,16 +597,12 @@   Just ((tree', a), e) -> Just (tree', (a, e))  -- | \(O(1)\) worst case. Inverse: 'halfunconsOddA'------ prop> \a (AnyEvenE as) -> halfunconsOddA (halfconsEvenE a as) == (a, as) halfconsEvenE :: a -> TwoFingerEvenE e a -> TwoFingerOddA e a halfconsEvenE a EmptyEvenE = EmptyOddA a halfconsEvenE a0 (SingleEvenE e1 a1) = SingleOddA a0 e1 a1 halfconsEvenE a0 (DeepEvenE pr m sf a1) = DeepOddA a0 pr m sf a1  -- | \(O(\log n)\) worst case. Inverse: 'halfunsnocOddE'.------ prop> \(AnyEvenE as) e -> halfunsnocOddE (halfsnocEvenE as e) == (as, e) halfsnocEvenE :: TwoFingerEvenE e a -> e -> TwoFingerOddE e a halfsnocEvenE EmptyEvenE e = SingleOddE e halfsnocEvenE (SingleEvenE e1 a1) e2 =@@ -636,8 +612,6 @@   Left (node, a', sf') -> DeepOddE pr (snocOddA m node a') sf'  -- | \(O(\log n)\) worst case. Inverse: 'halfconsOddA'.------ prop> \(AnyEvenE as) -> as == maybe mempty (uncurry halfconsOddA) (halfunconsEvenE as) halfunconsEvenE :: TwoFingerEvenE e a -> Maybe (e, TwoFingerOddA e a) halfunconsEvenE EmptyEvenE = Nothing halfunconsEvenE (SingleEvenE e a) = Just (e, EmptyOddA a)@@ -646,8 +620,6 @@   (e, Just (a0, pr')) -> (e, DeepOddA a0 pr' m sf a1)  -- | \(O(1)\) worst case. Inverse: 'halfsnocOddE'.------ prop> \(AnyEvenE as) -> as == maybe mempty (uncurry halfsnocOddE) (halfunsnocEvenE as) halfunsnocEvenE :: TwoFingerEvenE e a -> Maybe (TwoFingerOddE e a, a) halfunsnocEvenE EmptyEvenE = Nothing halfunsnocEvenE (SingleEvenE e a) = Just (SingleOddE e, a)@@ -671,8 +643,6 @@   Just ((tree', e), a) -> Just (tree', (e, a))  -- | \(O(\log n)\) worst case. Inverse: 'halfunconsOddE'.------ prop> \e (AnyEvenA as) -> halfunconsOddE (halfconsEvenA e as) == (e, as) halfconsEvenA :: e -> TwoFingerEvenA e a -> TwoFingerOddE e a halfconsEvenA e EmptyEvenA = SingleOddE e halfconsEvenA e1 (SingleEvenA a1 e2) =@@ -682,24 +652,18 @@   Left (pr', a', node) -> DeepOddE pr' (consOddA a' node m) sf  -- | \(O(1)\) worst case. Inverse: 'halfunsnocOddA'.------ prop> \(AnyEvenA as) a -> halfunsnocOddA (halfsnocEvenA as a) == (as, a) halfsnocEvenA :: TwoFingerEvenA e a -> a -> TwoFingerOddA e a halfsnocEvenA EmptyEvenA a = EmptyOddA a halfsnocEvenA (SingleEvenA a1 e1) a2 = SingleOddA a1 e1 a2 halfsnocEvenA (DeepEvenA a0 pr m sf) a = DeepOddA a0 pr m sf a  -- | \(O(1)\) worst case. Inverse: 'halfconsOddE'.------ prop> \(AnyEvenA as) -> as == maybe mempty (uncurry halfconsOddE) (halfunconsEvenA as) halfunconsEvenA :: TwoFingerEvenA e a -> Maybe (a, TwoFingerOddE e a) halfunconsEvenA EmptyEvenA = Nothing halfunconsEvenA (SingleEvenA a e) = Just (a, SingleOddE e) halfunconsEvenA (DeepEvenA a pr m sf) = Just (a, DeepOddE pr m sf)  -- | \(O(\log n)\) worst case. Inverse: 'halfsnocOddA'.------ prop> \(AnyEvenA as) -> as == maybe mempty (uncurry halfsnocOddA) (halfunsnocEvenA as) halfunsnocEvenA :: TwoFingerEvenA e a -> Maybe (TwoFingerOddA e a, e) halfunsnocEvenA EmptyEvenA = Nothing halfunsnocEvenA (SingleEvenA a e) = Just (EmptyOddA a, e)@@ -709,7 +673,6 @@  -- * Monad and Applicative instances, and related operations ---TODO: should be able to write some property tests for this. joinOddA :: TwoFingerOddA (TwoFingerOddE e a) (TwoFingerOddA e a) -> TwoFingerOddA e a joinOddA (halfunconsOddA -> (a, tree)) = appendOddAEvenE a (joinEvenE tree) @@ -778,14 +741,9 @@  -- * Concatenation of TwoFingerOddA. --- |--- prop> \(AnyOddA a) (AnyOddA b) (AnyOddA c) -> (a <> b) <> c == a <> (b <> c) instance (Semigroup a) => Semigroup (TwoFingerOddA e a) where   (<>) = appendOddA0 --- |--- prop> \(AnyOddA a) -> a == mempty <> a--- prop> \(AnyOddA a) -> a == a <> mempty instance (Monoid a, Semigroup a) => Monoid (TwoFingerOddA e a) where   mempty = singletonOddA mempty   mappend = (<>)@@ -1124,17 +1082,12 @@  -- * Concatenation of TwoFingerEvenE. --- |--- prop> \(AnyEvenE a) (AnyEvenE b) (AnyEvenE c) -> (a <> b) <> c == a <> (b <> c) instance Semigroup (TwoFingerEvenE e a) where   (<>) = appendEvenE  instance Alt (TwoFingerEvenE e) where   (<!>) = appendEvenE --- |--- prop> \(AnyEvenE a) -> a == a <> mempty--- prop> \(AnyEvenE a) -> a == mempty <> a instance Monoid (TwoFingerEvenE e a) where   mempty = EmptyEvenE   mappend = (<>)@@ -1152,17 +1105,12 @@  -- * Concatenation of TwoFingerEvenA. --- |--- prop> \(AnyEvenA a) (AnyEvenA b) (AnyEvenA c) -> (a <> b) <> c == a <> (b <> c) instance Semigroup (TwoFingerEvenA e a) where   (<>) = appendEvenA  instance Alt (TwoFingerEvenA e) where   (<!>) = appendEvenA --- |--- prop> \(AnyEvenA a) -> a == a <> mempty--- prop> \(AnyEvenA a) -> a == mempty <> a instance Monoid (TwoFingerEvenA e a) where   mempty = EmptyEvenA   mappend = (<>)@@ -1180,8 +1128,6 @@  -- * Monoid actions --- |--- prop> \(AnyOddA a) -> a == appendOddAEvenE a mempty appendOddAEvenE :: TwoFingerOddA e a -> TwoFingerEvenE e a -> TwoFingerOddA e a appendOddAEvenE (EmptyOddA a) m = halfconsEvenE a m appendOddAEvenE m EmptyEvenE = m@@ -1190,8 +1136,6 @@ appendOddAEvenE (DeepOddA a1 pr1 m1 sf1 a2) (DeepEvenE pr2 m2 sf2 a3) =   DeepOddA a1 pr1 (addDigits0 m1 sf1 a2 pr2 m2) sf2 a3 --- |--- prop> \(AnyOddA a) -> a == appendEvenAOddA mempty a appendEvenAOddA :: TwoFingerEvenA e a -> TwoFingerOddA e a -> TwoFingerOddA e a appendEvenAOddA EmptyEvenA m = m appendEvenAOddA m (EmptyOddA a) = halfsnocEvenA m a@@ -1214,8 +1158,6 @@ appendOddEOddA (DeepOddE pr1 m1 sf1) (DeepOddA a1 pr2 m2 sf2 a2) =   DeepEvenE pr1 (addDigits0 m1 sf1 a1 pr2 m2) sf2 a2 --- |--- prop> \(AnyOddE a) -> a == appendOddEEvenA a mempty appendOddEEvenA :: TwoFingerOddE e a -> TwoFingerEvenA e a -> TwoFingerOddE e a appendOddEEvenA m EmptyEvenA = m appendOddEEvenA (SingleOddE e) m = halfconsEvenA e m@@ -1223,8 +1165,6 @@ appendOddEEvenA (DeepOddE pr1 m1 sf1) (DeepEvenA a pr2 m2 sf2) =   DeepOddE pr1 (addDigits0 m1 sf1 a pr2 m2) sf2 --- |--- prop> \(AnyOddE a) -> a == appendEvenEOddE mempty a appendEvenEOddE :: TwoFingerEvenE e a -> TwoFingerOddE e a -> TwoFingerOddE e a appendEvenEOddE EmptyEvenE m = m appendEvenEOddE (SingleEvenE a e) m = consOddE a e m@@ -1232,98 +1172,6 @@ appendEvenEOddE (DeepEvenE pr1 m1 sf1 a) (DeepOddE pr2 m2 sf2) =   DeepOddE pr1 (addDigits0 m1 sf1 a pr2 m2) sf2 --- * QuickCheck stuff.-genDigit :: Gen e -> Gen a -> Gen (Digit e a)-genDigit e a = QC.oneof-  [ One <$> e-  , Two <$> e <*> a <*> e-  , Three <$> e <*> a <*> e <*> a <*> e-  , Four <$> e <*> a <*> e <*> a <*> e <*> a <*> e-  ]--genNode :: Gen e -> Gen a -> Gen (Node e a)-genNode e a = QC.oneof-  [ Node2 <$> e <*> a <*> e-  , Node3 <$> e <*> a <*> e <*> a <*> e-  ]---- | The 'Int' parameter is expontential size: for a value \(n\), the generated tree will have (slightly more than) \(2^n\) to \(3^n\) elements.-genOddA :: Gen e -> Gen a -> Int -> Gen (TwoFingerOddA e a)-genOddA e a 1 = SingleOddA <$> a <*> e <*> a-genOddA _ a n | n <= 0 = EmptyOddA <$> a-genOddA e a n =-  DeepOddA <$> a <*> genDigit e a <*> genOddA (genNode e a) a (n - 2) <*> genDigit e a <*> a----TODO: better shrinks? This isn't wrong, and it's better than the default, but we could be doing better (e.g., trying just the middle tree in Deep; also possibly just dropping things off the ends...).-shrinkOddA :: TwoFingerOddA e a -> [TwoFingerOddA e a]-shrinkOddA = \case-  EmptyOddA _ -> []-  SingleOddA a1 _ a2 ->-    [ EmptyOddA a1-    , EmptyOddA a2-    ]-  DeepOddA a0 pr m sf a1 -> mconcat-    [ [ halfsnocEvenA (halfconsOddE a0 $ digitToTree pr) (fst $ halfunconsOddA m)-      , halfconsEvenE (snd $ halfunsnocOddA m) (halfsnocOddE (digitToTree sf) a1)-      ]-    , [EmptyOddA a0]-    , [EmptyOddA a1]-    , (\m' -> DeepOddA a0 pr m' sf a1) <$> shrinkOddA m-    ]--shrinkOddE :: TwoFingerOddE e a -> [TwoFingerOddE e a]-shrinkOddE (SingleOddE _) = []-shrinkOddE (DeepOddE pr m sf) = (\m' -> DeepOddE pr m' sf) <$> shrinkOddA m--shrinkEvenA :: TwoFingerEvenA e a -> [TwoFingerEvenA e a]-shrinkEvenA tree = case unconsEvenA tree of-  Nothing -> []-  Just (_, tree') -> [tree']--shrinkEvenE :: TwoFingerEvenE e a -> [TwoFingerEvenE e a]-shrinkEvenE tree = case unconsEvenE tree of-  Nothing -> []-  Just (_, tree') -> [tree']--newtype AnyOddA = AnyOddA { getAnyOddA :: TwoFingerOddA Int [Int] }-  deriving (Show)--instance QC.Arbitrary AnyOddA where-  arbitrary = fmap AnyOddA $ genOddA QC.arbitrary QC.arbitrary =<< QC.choose (0, 10)-  shrink = fmap AnyOddA . shrinkOddA . getAnyOddA--newtype AnyOddE = AnyOddE { getAnyOddE :: TwoFingerOddE Int [Int] }-  deriving (Show)--instance QC.Arbitrary AnyOddE where-  arbitrary = AnyOddE <$> QC.oneof-    [ SingleOddE <$> QC.arbitrary-    , DeepOddE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary-    ]-  shrink = fmap AnyOddE . shrinkOddE . getAnyOddE--newtype AnyEvenA = AnyEvenA { getAnyEvenA :: TwoFingerEvenA Int [Int] }-  deriving (Show)--instance QC.Arbitrary AnyEvenA where-  arbitrary = AnyEvenA <$> QC.oneof-    [ pure EmptyEvenA-    , SingleEvenA <$> QC.arbitrary <*> QC.arbitrary-    , DeepEvenA <$> QC.arbitrary <*> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary-    ]-  shrink = fmap AnyEvenA . shrinkEvenA . getAnyEvenA--newtype AnyEvenE = AnyEvenE { getAnyEvenE :: TwoFingerEvenE Int [Int] }-  deriving (Show)--instance QC.Arbitrary AnyEvenE where-  arbitrary = AnyEvenE <$> QC.oneof-    [ pure EmptyEvenE-    , SingleEvenE <$> QC.arbitrary <*> QC.arbitrary-    , DeepEvenE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary <*> QC.arbitrary-    ]-  shrink = fmap AnyEvenE . shrinkEvenE . getAnyEvenE- -- * Aligning/zipping.  -- | Align two 'TwoFingerOddA' sequences elementwise, and return the excess remainder.@@ -1333,8 +1181,6 @@ -- -- >>> alignLeftOddAOddA (consOddA 'a' 1 $ singletonOddA 'b') (consOddA "foo" 10 $ consOddA "bar" 20 $ singletonOddA "baz") -- (consOddA ('a',"foo") (1,10) (singletonOddA ('b',"bar")),Right (consEvenE 20 "baz" mempty))------ prop> \(AnyOddA as) (AnyOddA bs) -> let { (aligned, rest) = alignLeftOddAOddA as bs ; as' = appendOddAEvenE (bimap fst fst aligned) (either id (const mempty) rest) ; bs' = appendOddAEvenE (bimap snd snd aligned) (either (const mempty) id rest) } in as == as' && bs == bs' alignLeftOddAOddA :: TwoFingerOddA e a -> TwoFingerOddA e' a' -> (TwoFingerOddA (e, e') (a, a'), Either (TwoFingerEvenE e a) (TwoFingerEvenE e' a')) alignLeftOddAOddA as (halfunsnocOddA -> (bs, a')) = case alignLeftOddAEvenA as bs of   Left (aligned, halfunconsOddA -> (a, rest)) ->@@ -1348,8 +1194,6 @@ -- -- >>> alignLeftOddAEvenA (consOddA 'a' 1 $ singletonOddA 'b') (consEvenA "foo" 10 $ consEvenA "bar" 20 $ consEvenA "baz" 30 mempty) -- Right (consOddA ('a',"foo") (1,10) (singletonOddA ('b',"bar")),consOddE 20 "baz" (singletonOddE 30))------ prop> \(AnyOddA as) (AnyEvenA bs) -> let { (as', bs') = case alignLeftOddAEvenA as bs of { Left (aligned, rest) -> (appendEvenAOddA (bimap fst fst aligned) rest, bimap snd snd aligned) ; Right (aligned, rest) -> (bimap fst fst aligned, appendOddAOddE (bimap snd snd aligned) rest) } } in as == as' && bs == bs' alignLeftOddAEvenA :: TwoFingerOddA e a -> TwoFingerEvenA e' a' -> Either (TwoFingerEvenA (e, e') (a, a'), TwoFingerOddA e a) (TwoFingerOddA (e, e') (a, a'), TwoFingerOddE e' a') alignLeftOddAEvenA as bs = case (unconsOddA as, unconsEvenA bs) of   (Right ((a, e), as'), Just ((a', e'), bs')) -> case alignLeftOddAEvenA as' bs' of@@ -1371,15 +1215,11 @@ -- -- >>> alignLeftOddEOddE (consOddE 'a' 1 $ singletonOddE 'b') (consOddE "foo" 10 $ consOddE "bar" 20 $ singletonOddE "baz") -- (consOddE ('a',"foo") (1,10) (singletonOddE ('b',"bar")),Right (consEvenA 20 "baz" mempty))------ prop> \(AnyOddE as) (AnyOddE bs) -> let { (aligned, rest) = alignLeftOddEOddE as bs ; as' = appendOddEEvenA (bimap fst fst aligned) (either id (const mempty) rest) ; bs' = appendOddEEvenA (bimap snd snd aligned) (either (const mempty) id rest) } in as == as' && bs == bs' alignLeftOddEOddE :: TwoFingerOddE e a -> TwoFingerOddE e' a' -> (TwoFingerOddE (e, e') (a, a'), Either (TwoFingerEvenA e a) (TwoFingerEvenA e' a')) alignLeftOddEOddE as (halfunsnocOddE -> (bs, e')) = case alignLeftOddEEvenE as bs of   Left (aligned, halfunconsOddE -> (e, rest)) -> (halfsnocEvenE aligned (e, e'), Left rest)   Right (aligned, rest) -> (aligned, Right $ halfsnocOddA rest e') --- |--- prop> \(AnyOddE as) (AnyEvenE bs) -> let { (as', bs') = case alignLeftOddEEvenE as bs of { Left (aligned, rest) -> (appendEvenEOddE (bimap fst fst aligned) rest, bimap snd snd aligned) ; Right (aligned, rest) -> (bimap fst fst aligned, appendOddEOddA (bimap snd snd aligned) rest) } } in as == as' && bs == bs' alignLeftOddEEvenE :: TwoFingerOddE e a -> TwoFingerEvenE e' a' -> Either (TwoFingerEvenE (e, e') (a, a'), TwoFingerOddE e a) (TwoFingerOddE (e, e') (a, a'), TwoFingerOddA e' a') alignLeftOddEEvenE as bs = case (unconsOddE as, unconsEvenE bs) of   (Right ((e, a), as'), Just ((e', a'), bs')) -> case alignLeftOddEEvenE as' bs' of@@ -1430,9 +1270,6 @@   in DeepOddA a0 (nodeToDigit prNode) inner (nodeToDigit sfNode) an  -- | Infinitely repeat the given @a@ and @e@.------ prop> \(AnyOddA as) -> as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddAOddA (repeatOddA id id) as)--- prop> \(AnyEvenA as) -> either ((as ==) . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) (alignLeftOddAEvenA (repeatOddA id id) as) repeatOddA :: a -> e -> TwoFingerOddA e a repeatOddA a e = infiniteOddA (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id e) (Stream.iterate id a) @@ -1448,9 +1285,6 @@ infiniteOddA = infiniteOddA' takeSingleNodeLeft takeSingleNodeRight  -- | Infinitely repeat the given @a@ and @e@.------ prop> \(AnyOddE as) -> as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddEOddE (repeatOddE id id) as)--- prop> \(AnyEvenE as) -> either ((==) as . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) $ alignLeftOddEEvenE (repeatOddE id id) as repeatOddE :: e -> a -> TwoFingerOddE e a repeatOddE e a = infiniteOddE (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id a) (Stream.iterate id e) @@ -1470,9 +1304,6 @@     inner = infiniteOddA' (takeNodeLeft takeSingleNodeLeft) (takeNodeRight takeSingleNodeRight) leftE' leftA' rightA' rightE'  -- | Infinitely repeat the given @a@ and @e@.------ prop> \(AnyEvenA as) -> as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenAEvenA (repeatEvenA id id) as)--- prop> \(AnyOddA as) -> either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddAEvenA as (repeatEvenA id id) repeatEvenA :: a -> e -> TwoFingerEvenA e a repeatEvenA a e = infiniteEvenA (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id e) @@ -1487,10 +1318,6 @@ infiniteEvenA (a :> leftA) leftE rightA rightE =   halfconsOddE a $ infiniteOddE leftE leftA rightA rightE --- |------ prop> \(AnyEvenE as) -> as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenEEvenE (repeatEvenE id id) as)--- prop> \(AnyOddE as) -> either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddEEvenE as (repeatEvenE id id) repeatEvenE :: e -> a -> TwoFingerEvenE e a repeatEvenE e a = infiniteEvenE (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id a) 

@@ -0,0 +1,306 @@+module Main+  ( main+  )+  where++import Control.Monad (join)+import Data.Bifunctor (bimap)+import Data.Semigroup ((<>))+import Test.Tasty (TestTree, testGroup, defaultMain)+import Test.Tasty.QuickCheck (Gen, Arbitrary, testProperty)+import qualified Test.Tasty.QuickCheck as QC++import Q4C12.TwoFinger.Internal (Digit (One, Two, Three, Four), TwoFingerOddA (SingleOddA, EmptyOddA, DeepOddA), TwoFingerOddE (SingleOddE, DeepOddE), TwoFingerEvenA (SingleEvenA, EmptyEvenA, DeepEvenA), TwoFingerEvenE (SingleEvenE, EmptyEvenE, DeepEvenE), Node (Node2, Node3), unconsEvenA, unconsEvenE, digitToTree, halfsnocOddA, halfsnocOddE, halfunsnocOddA, halfconsEvenE, halfunconsOddA, halfconsOddE, halfsnocEvenA, repeatEvenA, repeatEvenE, repeatOddA, repeatOddE, alignLeftOddAOddA, alignLeftOddAEvenA, alignLeftOddEOddE, alignLeftOddEEvenE, alignLeftEvenAEvenA, alignLeftEvenEEvenE, appendOddEOddA, appendEvenEOddE, appendOddEEvenA, appendOddAOddE, appendEvenAOddA, appendOddAEvenE, halfunsnocEvenA, halfunsnocEvenE, halfsnocEvenE, halfunconsEvenA, halfunsnocOddE, halfunconsEvenE, halfconsOddA, halfunconsOddE, halfconsEvenA)++genDigit :: Gen e -> Gen a -> Gen (Digit e a)+genDigit e a = QC.oneof+  [ One <$> e+  , Two <$> e <*> a <*> e+  , Three <$> e <*> a <*> e <*> a <*> e+  , Four <$> e <*> a <*> e <*> a <*> e <*> a <*> e+  ]++genNode :: Gen e -> Gen a -> Gen (Node e a)+genNode e a = QC.oneof+  [ Node2 <$> e <*> a <*> e+  , Node3 <$> e <*> a <*> e <*> a <*> e+  ]++-- | The 'Int' parameter is expontential size: for a value \(n\), the generated tree will have (slightly more than) \(2^n\) to \(3^n\) elements.+genOddA :: Gen e -> Gen a -> Int -> Gen (TwoFingerOddA e a)+genOddA e a 1 = SingleOddA <$> a <*> e <*> a+genOddA _ a n | n <= 0 = EmptyOddA <$> a+genOddA e a n =+  DeepOddA <$> a <*> genDigit e a <*> genOddA (genNode e a) a (n - 2) <*> genDigit e a <*> a++--TODO: better shrinks? This isn't wrong, and it's better than the default, but we could be doing better (e.g., trying just the middle tree in Deep; also possibly just dropping things off the ends...).+shrinkOddA :: TwoFingerOddA e a -> [TwoFingerOddA e a]+shrinkOddA = \case+  EmptyOddA _ -> []+  SingleOddA a1 _ a2 ->+    [ EmptyOddA a1+    , EmptyOddA a2+    ]+  DeepOddA a0 pr m sf a1 -> mconcat+    [ [ halfsnocEvenA (halfconsOddE a0 $ digitToTree pr) (fst $ halfunconsOddA m)+      , halfconsEvenE (snd $ halfunsnocOddA m) (halfsnocOddE (digitToTree sf) a1)+      ]+    , [EmptyOddA a0]+    , [EmptyOddA a1]+    , (\m' -> DeepOddA a0 pr m' sf a1) <$> shrinkOddA m+    ]++shrinkOddE :: TwoFingerOddE e a -> [TwoFingerOddE e a]+shrinkOddE (SingleOddE _) = []+shrinkOddE (DeepOddE pr m sf) = (\m' -> DeepOddE pr m' sf) <$> shrinkOddA m++shrinkEvenA :: TwoFingerEvenA e a -> [TwoFingerEvenA e a]+shrinkEvenA tree = case unconsEvenA tree of+  Nothing -> []+  Just (_, tree') -> [tree']++shrinkEvenE :: TwoFingerEvenE e a -> [TwoFingerEvenE e a]+shrinkEvenE tree = case unconsEvenE tree of+  Nothing -> []+  Just (_, tree') -> [tree']++newtype AnyOddA e a = AnyOddA { getAnyOddA :: TwoFingerOddA e a }+  deriving (Show)++instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddA e a) where+  arbitrary = fmap AnyOddA $ genOddA QC.arbitrary QC.arbitrary =<< QC.choose (0, 10)+  shrink = fmap AnyOddA . shrinkOddA . getAnyOddA++newtype AnyOddE e a = AnyOddE { getAnyOddE :: TwoFingerOddE e a }+  deriving (Show)++instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddE e a) where+  arbitrary = AnyOddE <$> QC.oneof+    [ SingleOddE <$> QC.arbitrary+    , DeepOddE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary+    ]+  shrink = fmap AnyOddE . shrinkOddE . getAnyOddE++newtype AnyEvenA e a = AnyEvenA { getAnyEvenA :: TwoFingerEvenA e a }+  deriving (Show)++instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyEvenA e a) where+  arbitrary = AnyEvenA <$> QC.oneof+    [ pure EmptyEvenA+    , SingleEvenA <$> QC.arbitrary <*> QC.arbitrary+    , DeepEvenA <$> QC.arbitrary <*> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary+    ]+  shrink = fmap AnyEvenA . shrinkEvenA . getAnyEvenA++newtype AnyEvenE e a = AnyEvenE { getAnyEvenE :: TwoFingerEvenE e a }+  deriving (Show)++instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyEvenE e a) where+  arbitrary = AnyEvenE <$> QC.oneof+    [ pure EmptyEvenE+    , SingleEvenE <$> QC.arbitrary <*> QC.arbitrary+    , DeepEvenE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary <*> QC.arbitrary+    ]+  shrink = fmap AnyEvenE . shrinkEvenE . getAnyEvenE++intFields :: (p Int [Int] -> r) -> p Int [Int] -> r+intFields = id++halfconsProperties :: TestTree+halfconsProperties = testGroup "half operations"+  [ testGroup "halfcons"+    [ testProperty "OddA" $ \e -> intFields $ \(AnyOddA as) ->+        halfunconsEvenE (halfconsOddA e as) == Just (e, as)+    , testProperty "OddE" $ \a -> intFields $ \(AnyOddE as) ->+        halfunconsEvenA (halfconsOddE a as) == Just (a, as)+    , testProperty "EvenA" $ \a -> intFields $ \(AnyEvenE as) ->+        halfunconsOddA (halfconsEvenE a as) == (a, as)+    , testProperty "EvenE" $ \e -> intFields $ \(AnyEvenA as) ->+        halfunconsOddE (halfconsEvenA e as) == (e, as)+    ]+  , testGroup "halfsnoc"+    [ testProperty "OddA" $ \e -> intFields $ \(AnyOddA as) ->+        halfunsnocEvenA (halfsnocOddA as e) == Just (as, e)+    , testProperty "OddE" $ \a -> intFields $ \(AnyOddE as) ->+        halfunsnocEvenE (halfsnocOddE as a) == Just (as, a)+    , testProperty "EvenA" $ \e -> intFields $ \(AnyEvenE as) ->+        halfunsnocOddE (halfsnocEvenE as e) == (as, e)+    , testProperty "EvenE" $ \a -> intFields $ \(AnyEvenA as) ->+        halfunsnocOddA (halfsnocEvenA as a) == (as, a)+    ]+  , testGroup "halfuncons"+    [ testProperty "OddA" $ intFields $ \(AnyOddA as) ->+        as == uncurry halfconsEvenE (halfunconsOddA as)+    , testProperty "OddE" $ intFields $  \(AnyOddE as) ->+        as == uncurry halfconsEvenA (halfunconsOddE as)+    , testProperty "EvenA" $ intFields $ \(AnyEvenE as) ->+        as == maybe mempty (uncurry halfconsOddA) (halfunconsEvenE as)+    , testProperty "EvenE" $ intFields $ \(AnyEvenA as) ->+        as == maybe mempty (uncurry halfconsOddE) (halfunconsEvenA as)+    ]+  , testGroup "halfunsnoc"+    [ testProperty "OddA" $ intFields $ \(AnyOddA as) ->+        as == uncurry halfsnocEvenA (halfunsnocOddA as)+    , testProperty "OddE" $ intFields $  \(AnyOddE as) ->+        as == uncurry halfsnocEvenE (halfunsnocOddE as)+    , testProperty "EvenA" $ intFields $ \(AnyEvenE as) ->+        as == maybe mempty (uncurry halfsnocOddE) (halfunsnocEvenE as)+    , testProperty "EvenE" $ intFields $ \(AnyEvenA as) ->+        as == maybe mempty (uncurry halfsnocOddA) (halfunsnocEvenA as)+    ]+  ]++associativeProperties :: TestTree+associativeProperties = testGroup "associativity"+  [ testGroup "leftmost AnyOddA"+    [ testProperty "OddA OddA" $ intFields $ \(AnyOddA a) (AnyOddA b) (AnyOddA c) ->+        a <> (b <> c) == (a <> b) <> c+    , testProperty "OddA EvenE" $ intFields $ \(AnyOddA a) (AnyOddA b) (AnyEvenE c) ->+        appendOddAEvenE (a <> b) c == a <> appendOddAEvenE b c+    , testProperty "OddE OddA" $ intFields $ \(AnyOddA a) (AnyOddE b) (AnyOddA c) ->+        appendEvenAOddA (appendOddAOddE a b) c == appendOddAEvenE a (appendOddEOddA b c)+    , testProperty "OddE EvenA" $ intFields $ \(AnyOddA a) (AnyOddE b) (AnyEvenA c) ->+        appendOddAOddE a (appendOddEEvenA b c) == appendOddAOddE a b <> c+    , testProperty "EvenE OddE" $ intFields $ \(AnyOddA a) (AnyEvenE b) (AnyOddE c) ->+        appendOddAOddE a (appendEvenEOddE b c) == appendOddAOddE (appendOddAEvenE a b) c+    , testProperty "EvenE EvenE" $ intFields $ \(AnyOddA a) (AnyEvenE b) (AnyEvenE c) ->+        appendOddAEvenE a (b <> c) == appendOddAEvenE (appendOddAEvenE a b) c+    ]+  , testGroup "leftmost OddE"+    [ testProperty "OddA OddE" $ intFields $ \(AnyOddE a) (AnyOddA b) (AnyOddE c) ->+        appendOddEEvenA a (appendOddAOddE b c) == appendEvenEOddE (appendOddEOddA a b) c+    , testProperty "OddA EvenE" $ intFields $ \(AnyOddE a) (AnyOddA b) (AnyEvenE c) ->+        appendOddEOddA a (appendOddAEvenE b c) == appendOddEOddA a b <> c+    , testProperty "EvenA OddA" $ intFields $ \(AnyOddE a) (AnyEvenA b) (AnyOddA c) ->+        appendOddEOddA a (appendEvenAOddA b c) == appendOddEOddA (appendOddEEvenA a b) c+    , testProperty "EvenA EvenA" $ intFields $ \(AnyOddE a) (AnyEvenA b) (AnyEvenA c) ->+        appendOddEEvenA a (b <> c) == appendOddEEvenA (appendOddEEvenA a b) c+    ]+  , testGroup "leftmost EvenA"+    [ testProperty "EvenA EvenA" $ intFields $ \(AnyEvenA a) (AnyEvenA b) (AnyEvenA c) ->+        a <> (b <> c) == (a <> b) <> c+    , testProperty "OddA OddA" $ intFields $ \(AnyEvenA a) (AnyOddA b) (AnyOddA c) ->+        appendEvenAOddA a (b <> c) == appendEvenAOddA a b <> c+    , testProperty "OddA OddE" $ intFields $ \(AnyEvenA a) (AnyOddA b) (AnyOddE c) ->+        appendOddAOddE (appendEvenAOddA a b) c == a <> appendOddAOddE b c+    , testProperty "OddA EvenE" $ intFields $ \(AnyEvenA a) (AnyOddA b) (AnyEvenE c) ->+        appendOddAEvenE (appendEvenAOddA a b) c == appendEvenAOddA a (appendOddAEvenE b c)+    , testProperty "EvenA OddA" $ intFields $ \(AnyEvenA a) (AnyEvenA b) (AnyOddA c) ->+        appendEvenAOddA (a <> b) c == appendEvenAOddA a (appendEvenAOddA b c)+    ]+  , testGroup "leftmost EvenE"+    [ testProperty "EvenE EvenE" $ intFields $ \(AnyEvenE a) (AnyEvenE b) (AnyEvenE c) ->+        a <> (b <> c) == (a <> b) <> c+    , testProperty "OddE OddE" $ intFields $ \(AnyEvenE a) (AnyOddE b) (AnyOddA c) ->+        appendOddEOddA (appendEvenEOddE a b) c == a <> appendOddEOddA b c+    , testProperty "OddE EvenA" $ intFields $ \(AnyEvenE a) (AnyOddE b) (AnyEvenA c) ->+        appendOddEEvenA (appendEvenEOddE a b) c == appendEvenEOddE a (appendOddEEvenA b c)+    , testProperty "EvenE OddE" $ intFields $ \(AnyEvenE a) (AnyEvenE b) (AnyOddE c) ->+        appendEvenEOddE (a <> b) c == appendEvenEOddE a (appendEvenEOddE b c)+    ]+  ]++monoidIdentityProperties :: TestTree+monoidIdentityProperties = testGroup "monoidal identity"+  [ testProperty "left OddA OddA" $ intFields $ \(AnyOddA a) ->+      a == mempty <> a+  , testProperty "right OddA OddA" $ intFields $ \(AnyOddA a) ->+      a == a <> mempty+  , testProperty "left EvenA EvenA" $ intFields $ \(AnyEvenA a) ->+      a == mempty <> a+  , testProperty "right EvenA EvenA" $ intFields $ \(AnyEvenA a) ->+      a == a <> mempty+  , testProperty "left EvenE EvenE" $ intFields $ \(AnyEvenE a) ->+      a == mempty <> a+  , testProperty "right EvenE EvenE" $ intFields $ \(AnyEvenE a) ->+      a == a <> mempty+  , testProperty "right OddA EvenE" $ intFields $ \(AnyOddA a) ->+      a == appendOddAEvenE a mempty+  , testProperty "left EvenA OddA" $ intFields $ \(AnyOddA a) ->+      a == appendEvenAOddA mempty a+  , testProperty "left EvenE OddE" $ intFields $ \(AnyOddE a) ->+      a == appendEvenEOddE mempty a+  , testProperty "right OddE EvenA" $ intFields $ \(AnyOddE a) ->+      a == appendOddEEvenA a mempty+  ]++alignProperties :: TestTree+alignProperties = testGroup "aligning is lossless"+  [ testProperty "OddA OddA" $ intFields $ \(AnyOddA as) -> intFields $ \(AnyOddA bs) ->+      let (aligned, rest) = alignLeftOddAOddA as bs+          as' = appendOddAEvenE (bimap fst fst aligned) (either id (const mempty) rest)+          bs' = appendOddAEvenE (bimap snd snd aligned) (either (const mempty) id rest)+      in as == as' && bs == bs'+  , testProperty "OddA EvenA" $ intFields $ \(AnyOddA as) -> intFields $ \(AnyEvenA bs) ->+      let (as', bs') = case alignLeftOddAEvenA as bs of+            Left (aligned, rest) ->+              (appendEvenAOddA (bimap fst fst aligned) rest, bimap snd snd aligned)+            Right (aligned, rest) ->+              (bimap fst fst aligned, appendOddAOddE (bimap snd snd aligned) rest)+      in as == as' && bs == bs'+  , testProperty "OddE OddE" $ intFields $ \(AnyOddE as) -> intFields $ \(AnyOddE bs) ->+      let (aligned, rest) = alignLeftOddEOddE as bs+          as' = appendOddEEvenA (bimap fst fst aligned) (either id (const mempty) rest)+          bs' = appendOddEEvenA (bimap snd snd aligned) (either (const mempty) id rest)+      in as == as' && bs == bs'+  , testProperty "OddE EvenE" $ intFields $ \(AnyOddE as) -> intFields $ \(AnyEvenE bs) ->+      let (as', bs') = case alignLeftOddEEvenE as bs of+            Left (aligned, rest) ->+              (appendEvenEOddE (bimap fst fst aligned) rest, bimap snd snd aligned)+            Right (aligned, rest) ->+              (bimap fst fst aligned, appendOddEOddA (bimap snd snd aligned) rest)+      in as == as' && bs == bs'+  ]++alignIdentityProperties :: TestTree+alignIdentityProperties = testGroup "align identities"+  [ testProperty "left OddA OddA" $ intFields $ \(AnyOddA as) ->+      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddAOddA (repeatOddA id id) as)+  , testProperty "right OddA OddA" $ intFields $ \(AnyOddA as) ->+      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftOddAOddA as (repeatOddA id id))+  , testProperty "left OddA EvenA" $ intFields $ \(AnyEvenA as) ->+      either ((as ==) . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) (alignLeftOddAEvenA (repeatOddA id id) as)+  , testProperty "right OddA EvenA" $ intFields $ \(AnyOddA as) ->+      either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddAEvenA as (repeatEvenA id id)+  , testProperty "left OddE OddE" $ intFields $ \(AnyOddE as) ->+      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddEOddE (repeatOddE id id) as)+  , testProperty "right OddE OddE" $ intFields $ \(AnyOddE as) ->+      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftOddEOddE as (repeatOddE id id))+  , testProperty "left OddE EvenE" $ intFields $ \(AnyEvenE as) ->+      either ((==) as . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) $ alignLeftOddEEvenE (repeatOddE id id) as+  , testProperty "right OddE EvenE" $ intFields $ \(AnyOddE as) ->+      either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddEEvenE as (repeatEvenE id id)+  , testProperty "left EvenA EvenA" $ intFields $ \(AnyEvenA as) ->+      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenAEvenA (repeatEvenA id id) as)+  , testProperty "right EvenA EvenA" $ intFields $ \(AnyEvenA as) ->+      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftEvenAEvenA as (repeatEvenA id id))+  , testProperty "left EvenE EvenE" $ intFields $ \(AnyEvenE as) ->+      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenEEvenE (repeatEvenE id id) as)+  , testProperty "right EvenE EvenE" $ intFields $ \(AnyEvenE as) ->+      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftEvenEEvenE as (repeatEvenE id id))+  ]++monadProperties :: TestTree+monadProperties = testGroup "OddA monad laws"+  [ testProperty "join . join === join . fmap join" $+      --Since we generate 3 layers deep, the things can get big with the default settings.+      let gen :: Gen a -> Gen (TwoFingerOddA Int a)+          gen a = genOddA QC.arbitrary a =<< QC.choose (0, 3)+      in QC.forAll (gen $ gen $ gen QC.arbitrary) $ \as ->+           join (join as) == (join (fmap join as) :: TwoFingerOddA Int Int)+  , testProperty "join . pure === id" $ \(AnyOddA as) ->+      as == (join (pure as) :: TwoFingerOddA Int Int)+  , testProperty "join . fmap pure === id" $ \(AnyOddA as) ->+      as == (join (fmap pure as) :: TwoFingerOddA Int Int)+  ]++main :: IO ()+main = defaultMain $ testGroup "property tests"+  [ halfconsProperties+  , associativeProperties+  , monoidIdentityProperties+  , alignProperties+  , alignIdentityProperties+  , monadProperties+  ]+