EdisonCore 1.3.3.2 → 1.3.3.3

raw patch · 29 files changed

+13636/−13490 lines, 29 filesdep −arraydep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: array

Dependency ranges changed: base

API changes (from Hackage documentation)

- Data.Edison.Assoc.TernaryTrie: instance (GHC.Classes.Ord k, Test.QuickCheck.Arbitrary.Arbitrary k, Test.QuickCheck.Arbitrary.Arbitrary a) => Test.QuickCheck.Arbitrary.Arbitrary (Data.Edison.Assoc.TernaryTrie.FM k a)

+ Data.Edison.Assoc.TernaryTrie: instance (GHC.Real.Integral k, Test.QuickCheck.Arbitrary.Arbitrary k, Test.QuickCheck.Arbitrary.Arbitrary a) => Test.QuickCheck.Arbitrary.Arbitrary (Data.Edison.Assoc.TernaryTrie.FM k a)

+ Data.Edison.Assoc.TernaryTrie: instance (GHC.Show.Show k, GHC.Show.Show v) => GHC.Show.Show (Data.Edison.Assoc.TernaryTrie.FMB k v)

+ Data.Edison.Assoc.TernaryTrie: instance (GHC.Show.Show k, GHC.Show.Show v) => GHC.Show.Show (Data.Edison.Assoc.TernaryTrie.FMB' k v)

- Data.Edison.Seq.RevSeq: adjust :: Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: adjust :: forall (s :: Type -> Type) a. Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: append :: Sequence s => Rev s a -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: append :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: concat :: Sequence s => Rev s (Rev s a) -> Rev s a

+ Data.Edison.Seq.RevSeq: concat :: forall (s :: Type -> Type) a. Sequence s => Rev s (Rev s a) -> Rev s a

- Data.Edison.Seq.RevSeq: concatMap :: Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b

+ Data.Edison.Seq.RevSeq: concatMap :: forall (s :: Type -> Type) a b. Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b

- Data.Edison.Seq.RevSeq: copy :: Sequence s => Int -> a -> Rev s a

+ Data.Edison.Seq.RevSeq: copy :: forall (s :: Type -> Type) a. Sequence s => Int -> a -> Rev s a

- Data.Edison.Seq.RevSeq: data Rev s a

+ Data.Edison.Seq.RevSeq: data Rev (s :: Type -> Type) a

- Data.Edison.Seq.RevSeq: drop :: Sequence s => Int -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: drop :: forall (s :: Type -> Type) a. Sequence s => Int -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: dropWhile :: Sequence s => (a -> Bool) -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: dropWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: empty :: Sequence s => Rev s a

+ Data.Edison.Seq.RevSeq: empty :: forall (s :: Type -> Type) a. Sequence s => Rev s a

- Data.Edison.Seq.RevSeq: filter :: Sequence s => (a -> Bool) -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: filter :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: fold :: Sequence s => (a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: fold :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: fold' :: Sequence s => (a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: fold' :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: fold1 :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: fold1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: fold1' :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: fold1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: foldl :: Sequence s => (b -> a -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldl :: forall (s :: Type -> Type) b a. Sequence s => (b -> a -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldl' :: Sequence s => (b -> a -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldl' :: forall (s :: Type -> Type) b a. Sequence s => (b -> a -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldl1 :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: foldl1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: foldl1' :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: foldl1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: foldlWithIndex :: Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldlWithIndex :: forall (s :: Type -> Type) b a. Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldlWithIndex' :: Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldlWithIndex' :: forall (s :: Type -> Type) b a. Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldr :: Sequence s => (a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldr :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldr' :: Sequence s => (a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldr' :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldr1 :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: foldr1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: foldr1' :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: foldr1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: foldrWithIndex :: Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldrWithIndex :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: foldrWithIndex' :: Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b

+ Data.Edison.Seq.RevSeq: foldrWithIndex' :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b

- Data.Edison.Seq.RevSeq: fromList :: Sequence s => [a] -> Rev s a

+ Data.Edison.Seq.RevSeq: fromList :: forall (s :: Type -> Type) a. Sequence s => [a] -> Rev s a

- Data.Edison.Seq.RevSeq: inBounds :: Sequence s => Int -> Rev s a -> Bool

+ Data.Edison.Seq.RevSeq: inBounds :: forall (s :: Type -> Type) a. Sequence s => Int -> Rev s a -> Bool

- Data.Edison.Seq.RevSeq: instanceName :: Sequence s => Rev s a -> String

+ Data.Edison.Seq.RevSeq: instanceName :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> String

- Data.Edison.Seq.RevSeq: lcons :: Sequence s => a -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: lcons :: forall (s :: Type -> Type) a. Sequence s => a -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: lhead :: Sequence s => Rev s a -> a

+ Data.Edison.Seq.RevSeq: lhead :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> a

- Data.Edison.Seq.RevSeq: lheadM :: (Sequence s, MonadFail m) => Rev s a -> m a

+ Data.Edison.Seq.RevSeq: lheadM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m a

- Data.Edison.Seq.RevSeq: lookup :: Sequence s => Int -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: lookup :: forall (s :: Type -> Type) a. Sequence s => Int -> Rev s a -> a

- Data.Edison.Seq.RevSeq: lookupM :: (Sequence s, MonadFail m) => Int -> Rev s a -> m a

+ Data.Edison.Seq.RevSeq: lookupM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Int -> Rev s a -> m a

- Data.Edison.Seq.RevSeq: lookupWithDefault :: Sequence s => a -> Int -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: lookupWithDefault :: forall (s :: Type -> Type) a. Sequence s => a -> Int -> Rev s a -> a

- Data.Edison.Seq.RevSeq: ltail :: Sequence s => Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: ltail :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: ltailM :: (Sequence s, MonadFail m) => Rev s a -> m (Rev s a)

+ Data.Edison.Seq.RevSeq: ltailM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m (Rev s a)

- Data.Edison.Seq.RevSeq: lview :: (Sequence s, MonadFail m) => Rev s a -> m (a, Rev s a)

+ Data.Edison.Seq.RevSeq: lview :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m (a, Rev s a)

- Data.Edison.Seq.RevSeq: map :: Sequence s => (a -> b) -> Rev s a -> Rev s b

+ Data.Edison.Seq.RevSeq: map :: forall (s :: Type -> Type) a b. Sequence s => (a -> b) -> Rev s a -> Rev s b

- Data.Edison.Seq.RevSeq: mapWithIndex :: Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b

+ Data.Edison.Seq.RevSeq: mapWithIndex :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b

- Data.Edison.Seq.RevSeq: null :: Sequence s => Rev s a -> Bool

+ Data.Edison.Seq.RevSeq: null :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Bool

- Data.Edison.Seq.RevSeq: partition :: Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)

+ Data.Edison.Seq.RevSeq: partition :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)

- Data.Edison.Seq.RevSeq: rcons :: Sequence s => a -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: rcons :: forall (s :: Type -> Type) a. Sequence s => a -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: reduce1 :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reduce1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reduce1' :: Sequence s => (a -> a -> a) -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reduce1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reducel :: Sequence s => (a -> a -> a) -> a -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reducel :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reducel' :: Sequence s => (a -> a -> a) -> a -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reducel' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reducer :: Sequence s => (a -> a -> a) -> a -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reducer :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reducer' :: Sequence s => (a -> a -> a) -> a -> Rev s a -> a

+ Data.Edison.Seq.RevSeq: reducer' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Rev s a -> a

- Data.Edison.Seq.RevSeq: reverse :: Sequence s => Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: reverse :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: reverseOnto :: Sequence s => Rev s a -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: reverseOnto :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: rhead :: Sequence s => Rev s a -> a

+ Data.Edison.Seq.RevSeq: rhead :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> a

- Data.Edison.Seq.RevSeq: rheadM :: (Sequence s, MonadFail m) => Rev s a -> m a

+ Data.Edison.Seq.RevSeq: rheadM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m a

- Data.Edison.Seq.RevSeq: rtail :: Sequence s => Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: rtail :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: rtailM :: (Sequence s, MonadFail m) => Rev s a -> m (Rev s a)

+ Data.Edison.Seq.RevSeq: rtailM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m (Rev s a)

- Data.Edison.Seq.RevSeq: rview :: (Sequence s, MonadFail m) => Rev s a -> m (a, Rev s a)

+ Data.Edison.Seq.RevSeq: rview :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Rev s a -> m (a, Rev s a)

- Data.Edison.Seq.RevSeq: singleton :: Sequence s => a -> Rev s a

+ Data.Edison.Seq.RevSeq: singleton :: forall (s :: Type -> Type) a. Sequence s => a -> Rev s a

- Data.Edison.Seq.RevSeq: size :: Sequence s => Rev s a -> Int

+ Data.Edison.Seq.RevSeq: size :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Int

- Data.Edison.Seq.RevSeq: splitAt :: Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)

+ Data.Edison.Seq.RevSeq: splitAt :: forall (s :: Type -> Type) a. Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)

- Data.Edison.Seq.RevSeq: splitWhile :: Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)

+ Data.Edison.Seq.RevSeq: splitWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)

- Data.Edison.Seq.RevSeq: strict :: Sequence s => Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: strict :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: strictWith :: Sequence s => (a -> b) -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: strictWith :: forall (s :: Type -> Type) a b. Sequence s => (a -> b) -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: structuralInvariant :: Sequence s => Rev s a -> Bool

+ Data.Edison.Seq.RevSeq: structuralInvariant :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> Bool

- Data.Edison.Seq.RevSeq: subseq :: Sequence s => Int -> Int -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: subseq :: forall (s :: Type -> Type) a. Sequence s => Int -> Int -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: take :: Sequence s => Int -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: take :: forall (s :: Type -> Type) a. Sequence s => Int -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: takeWhile :: Sequence s => (a -> Bool) -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: takeWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: toList :: Sequence s => Rev s a -> [a]

+ Data.Edison.Seq.RevSeq: toList :: forall (s :: Type -> Type) a. Sequence s => Rev s a -> [a]

- Data.Edison.Seq.RevSeq: unzip :: Sequence s => Rev s (a, b) -> (Rev s a, Rev s b)

+ Data.Edison.Seq.RevSeq: unzip :: forall (s :: Type -> Type) a b. Sequence s => Rev s (a, b) -> (Rev s a, Rev s b)

- Data.Edison.Seq.RevSeq: unzip3 :: Sequence s => Rev s (a, b, c) -> (Rev s a, Rev s b, Rev s c)

+ Data.Edison.Seq.RevSeq: unzip3 :: forall (s :: Type -> Type) a b c. Sequence s => Rev s (a, b, c) -> (Rev s a, Rev s b, Rev s c)

- Data.Edison.Seq.RevSeq: unzipWith :: Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)

+ Data.Edison.Seq.RevSeq: unzipWith :: forall (s :: Type -> Type) a b c. Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)

- Data.Edison.Seq.RevSeq: unzipWith3 :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)

+ Data.Edison.Seq.RevSeq: unzipWith3 :: forall (s :: Type -> Type) a b c d. Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)

- Data.Edison.Seq.RevSeq: update :: Sequence s => Int -> a -> Rev s a -> Rev s a

+ Data.Edison.Seq.RevSeq: update :: forall (s :: Type -> Type) a. Sequence s => Int -> a -> Rev s a -> Rev s a

- Data.Edison.Seq.RevSeq: zip :: Sequence s => Rev s a -> Rev s b -> Rev s (a, b)

+ Data.Edison.Seq.RevSeq: zip :: forall (s :: Type -> Type) a b. Sequence s => Rev s a -> Rev s b -> Rev s (a, b)

- Data.Edison.Seq.RevSeq: zip3 :: Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a, b, c)

+ Data.Edison.Seq.RevSeq: zip3 :: forall (s :: Type -> Type) a b c. Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a, b, c)

- Data.Edison.Seq.RevSeq: zipWith :: Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c

+ Data.Edison.Seq.RevSeq: zipWith :: forall (s :: Type -> Type) a b c. Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c

- Data.Edison.Seq.RevSeq: zipWith3 :: Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d

+ Data.Edison.Seq.RevSeq: zipWith3 :: forall (s :: Type -> Type) a b c d. Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d

- Data.Edison.Seq.SizedSeq: adjust :: Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: adjust :: forall (s :: Type -> Type) a. Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: append :: Sequence s => Sized s a -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: append :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: concat :: Sequence s => Sized s (Sized s a) -> Sized s a

+ Data.Edison.Seq.SizedSeq: concat :: forall (s :: Type -> Type) a. Sequence s => Sized s (Sized s a) -> Sized s a

- Data.Edison.Seq.SizedSeq: concatMap :: Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b

+ Data.Edison.Seq.SizedSeq: concatMap :: forall (s :: Type -> Type) a b. Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b

- Data.Edison.Seq.SizedSeq: copy :: Sequence s => Int -> a -> Sized s a

+ Data.Edison.Seq.SizedSeq: copy :: forall (s :: Type -> Type) a. Sequence s => Int -> a -> Sized s a

- Data.Edison.Seq.SizedSeq: data Sized s a

+ Data.Edison.Seq.SizedSeq: data Sized (s :: Type -> Type) a

- Data.Edison.Seq.SizedSeq: drop :: Sequence s => Int -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: drop :: forall (s :: Type -> Type) a. Sequence s => Int -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: dropWhile :: Sequence s => (a -> Bool) -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: dropWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: empty :: Sequence s => Sized s a

+ Data.Edison.Seq.SizedSeq: empty :: forall (s :: Type -> Type) a. Sequence s => Sized s a

- Data.Edison.Seq.SizedSeq: filter :: Sequence s => (a -> Bool) -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: filter :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: fold :: Sequence s => (a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: fold :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: fold' :: Sequence s => (a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: fold' :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: fold1 :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: fold1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: fold1' :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: fold1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: foldl :: Sequence s => (b -> a -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldl :: forall (s :: Type -> Type) b a. Sequence s => (b -> a -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldl' :: Sequence s => (b -> a -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldl' :: forall (s :: Type -> Type) b a. Sequence s => (b -> a -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldl1 :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: foldl1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: foldl1' :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: foldl1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: foldlWithIndex :: Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldlWithIndex :: forall (s :: Type -> Type) b a. Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldlWithIndex' :: Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldlWithIndex' :: forall (s :: Type -> Type) b a. Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldr :: Sequence s => (a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldr :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldr' :: Sequence s => (a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldr' :: forall (s :: Type -> Type) a b. Sequence s => (a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldr1 :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: foldr1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: foldr1' :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: foldr1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: foldrWithIndex :: Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldrWithIndex :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: foldrWithIndex' :: Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b

+ Data.Edison.Seq.SizedSeq: foldrWithIndex' :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b

- Data.Edison.Seq.SizedSeq: fromList :: Sequence s => [a] -> Sized s a

+ Data.Edison.Seq.SizedSeq: fromList :: forall (s :: Type -> Type) a. Sequence s => [a] -> Sized s a

- Data.Edison.Seq.SizedSeq: inBounds :: Sequence s => Int -> Sized s a -> Bool

+ Data.Edison.Seq.SizedSeq: inBounds :: forall (s :: Type -> Type) a. Sequence s => Int -> Sized s a -> Bool

- Data.Edison.Seq.SizedSeq: instanceName :: Sequence s => Sized s a -> String

+ Data.Edison.Seq.SizedSeq: instanceName :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> String

- Data.Edison.Seq.SizedSeq: lcons :: Sequence s => a -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: lcons :: forall (s :: Type -> Type) a. Sequence s => a -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: lhead :: Sequence s => Sized s a -> a

+ Data.Edison.Seq.SizedSeq: lhead :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> a

- Data.Edison.Seq.SizedSeq: lheadM :: (Sequence s, MonadFail m) => Sized s a -> m a

+ Data.Edison.Seq.SizedSeq: lheadM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m a

- Data.Edison.Seq.SizedSeq: lookup :: Sequence s => Int -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: lookup :: forall (s :: Type -> Type) a. Sequence s => Int -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: lookupM :: (Sequence s, MonadFail m) => Int -> Sized s a -> m a

+ Data.Edison.Seq.SizedSeq: lookupM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Int -> Sized s a -> m a

- Data.Edison.Seq.SizedSeq: lookupWithDefault :: Sequence s => a -> Int -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: lookupWithDefault :: forall (s :: Type -> Type) a. Sequence s => a -> Int -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: ltail :: Sequence s => Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: ltail :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: ltailM :: (Sequence s, MonadFail m) => Sized s a -> m (Sized s a)

+ Data.Edison.Seq.SizedSeq: ltailM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m (Sized s a)

- Data.Edison.Seq.SizedSeq: lview :: (Sequence s, MonadFail m) => Sized s a -> m (a, Sized s a)

+ Data.Edison.Seq.SizedSeq: lview :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m (a, Sized s a)

- Data.Edison.Seq.SizedSeq: map :: Sequence s => (a -> b) -> Sized s a -> Sized s b

+ Data.Edison.Seq.SizedSeq: map :: forall (s :: Type -> Type) a b. Sequence s => (a -> b) -> Sized s a -> Sized s b

- Data.Edison.Seq.SizedSeq: mapWithIndex :: Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b

+ Data.Edison.Seq.SizedSeq: mapWithIndex :: forall (s :: Type -> Type) a b. Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b

- Data.Edison.Seq.SizedSeq: null :: Sequence s => Sized s a -> Bool

+ Data.Edison.Seq.SizedSeq: null :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Bool

- Data.Edison.Seq.SizedSeq: partition :: Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)

+ Data.Edison.Seq.SizedSeq: partition :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)

- Data.Edison.Seq.SizedSeq: rcons :: Sequence s => a -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: rcons :: forall (s :: Type -> Type) a. Sequence s => a -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: reduce1 :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reduce1 :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reduce1' :: Sequence s => (a -> a -> a) -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reduce1' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reducel :: Sequence s => (a -> a -> a) -> a -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reducel :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reducel' :: Sequence s => (a -> a -> a) -> a -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reducel' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reducer :: Sequence s => (a -> a -> a) -> a -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reducer :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reducer' :: Sequence s => (a -> a -> a) -> a -> Sized s a -> a

+ Data.Edison.Seq.SizedSeq: reducer' :: forall (s :: Type -> Type) a. Sequence s => (a -> a -> a) -> a -> Sized s a -> a

- Data.Edison.Seq.SizedSeq: reverse :: Sequence s => Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: reverse :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: reverseOnto :: Sequence s => Sized s a -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: reverseOnto :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: rhead :: Sequence s => Sized s a -> a

+ Data.Edison.Seq.SizedSeq: rhead :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> a

- Data.Edison.Seq.SizedSeq: rheadM :: (Sequence s, MonadFail m) => Sized s a -> m a

+ Data.Edison.Seq.SizedSeq: rheadM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m a

- Data.Edison.Seq.SizedSeq: rtail :: Sequence s => Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: rtail :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: rtailM :: (Sequence s, MonadFail m) => Sized s a -> m (Sized s a)

+ Data.Edison.Seq.SizedSeq: rtailM :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m (Sized s a)

- Data.Edison.Seq.SizedSeq: rview :: (Sequence s, MonadFail m) => Sized s a -> m (a, Sized s a)

+ Data.Edison.Seq.SizedSeq: rview :: forall (s :: Type -> Type) m a. (Sequence s, MonadFail m) => Sized s a -> m (a, Sized s a)

- Data.Edison.Seq.SizedSeq: singleton :: Sequence s => a -> Sized s a

+ Data.Edison.Seq.SizedSeq: singleton :: forall (s :: Type -> Type) a. Sequence s => a -> Sized s a

- Data.Edison.Seq.SizedSeq: size :: Sequence s => Sized s a -> Int

+ Data.Edison.Seq.SizedSeq: size :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Int

- Data.Edison.Seq.SizedSeq: splitAt :: Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)

+ Data.Edison.Seq.SizedSeq: splitAt :: forall (s :: Type -> Type) a. Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)

- Data.Edison.Seq.SizedSeq: splitWhile :: Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)

+ Data.Edison.Seq.SizedSeq: splitWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)

- Data.Edison.Seq.SizedSeq: strict :: Sequence s => Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: strict :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: strictWith :: Sequence s => (a -> b) -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: strictWith :: forall (s :: Type -> Type) a b. Sequence s => (a -> b) -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: structuralInvariant :: Sequence s => Sized s a -> Bool

+ Data.Edison.Seq.SizedSeq: structuralInvariant :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> Bool

- Data.Edison.Seq.SizedSeq: subseq :: Sequence s => Int -> Int -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: subseq :: forall (s :: Type -> Type) a. Sequence s => Int -> Int -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: take :: Sequence s => Int -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: take :: forall (s :: Type -> Type) a. Sequence s => Int -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: takeWhile :: Sequence s => (a -> Bool) -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: takeWhile :: forall (s :: Type -> Type) a. Sequence s => (a -> Bool) -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: toList :: Sequence s => Sized s a -> [a]

+ Data.Edison.Seq.SizedSeq: toList :: forall (s :: Type -> Type) a. Sequence s => Sized s a -> [a]

- Data.Edison.Seq.SizedSeq: unzip :: Sequence s => Sized s (a, b) -> (Sized s a, Sized s b)

+ Data.Edison.Seq.SizedSeq: unzip :: forall (s :: Type -> Type) a b. Sequence s => Sized s (a, b) -> (Sized s a, Sized s b)

- Data.Edison.Seq.SizedSeq: unzip3 :: Sequence s => Sized s (a, b, c) -> (Sized s a, Sized s b, Sized s c)

+ Data.Edison.Seq.SizedSeq: unzip3 :: forall (s :: Type -> Type) a b c. Sequence s => Sized s (a, b, c) -> (Sized s a, Sized s b, Sized s c)

- Data.Edison.Seq.SizedSeq: unzipWith :: Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)

+ Data.Edison.Seq.SizedSeq: unzipWith :: forall (s :: Type -> Type) a b c. Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)

- Data.Edison.Seq.SizedSeq: unzipWith3 :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)

+ Data.Edison.Seq.SizedSeq: unzipWith3 :: forall (s :: Type -> Type) a b c d. Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)

- Data.Edison.Seq.SizedSeq: update :: Sequence s => Int -> a -> Sized s a -> Sized s a

+ Data.Edison.Seq.SizedSeq: update :: forall (s :: Type -> Type) a. Sequence s => Int -> a -> Sized s a -> Sized s a

- Data.Edison.Seq.SizedSeq: zip :: Sequence s => Sized s a -> Sized s b -> Sized s (a, b)

+ Data.Edison.Seq.SizedSeq: zip :: forall (s :: Type -> Type) a b. Sequence s => Sized s a -> Sized s b -> Sized s (a, b)

- Data.Edison.Seq.SizedSeq: zip3 :: Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a, b, c)

+ Data.Edison.Seq.SizedSeq: zip3 :: forall (s :: Type -> Type) a b c. Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a, b, c)

- Data.Edison.Seq.SizedSeq: zipWith :: Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c

+ Data.Edison.Seq.SizedSeq: zipWith :: forall (s :: Type -> Type) a b c. Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c

- Data.Edison.Seq.SizedSeq: zipWith3 :: Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d

+ Data.Edison.Seq.SizedSeq: zipWith3 :: forall (s :: Type -> Type) a b c d. Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d

Files

CHANGES.md +123/−118
COPYRIGHT +25/−23
EdisonCore.cabal +81/−82
src/Data/Edison/Assoc/AssocList.hs +628/−628
src/Data/Edison/Assoc/Defaults.hs +315/−311
src/Data/Edison/Assoc/PatriciaLoMap.hs +854/−854
src/Data/Edison/Assoc/StandardMap.hs +362/−362
src/Data/Edison/Assoc/TernaryTrie.hs +1300/−1170
src/Data/Edison/Coll/Defaults.hs +249/−247
src/Data/Edison/Coll/EnumSet.hs +808/−808
src/Data/Edison/Coll/LazyPairingHeap.hs +572/−570
src/Data/Edison/Coll/LeftistHeap.hs +497/−496
src/Data/Edison/Coll/MinHeap.hs +410/−410
src/Data/Edison/Coll/SkewHeap.hs +465/−464
src/Data/Edison/Coll/SplayHeap.hs +498/−498
src/Data/Edison/Coll/StandardSet.hs +265/−265
src/Data/Edison/Coll/UnbalancedSet.hs +444/−443
src/Data/Edison/Concrete/FingerTree.hs +788/−788
src/Data/Edison/Seq/BankersQueue.hs +440/−440
src/Data/Edison/Seq/BinaryRandList.hs +468/−468
src/Data/Edison/Seq/BraunSeq.hs +567/−570
src/Data/Edison/Seq/Defaults.hs +516/−514
src/Data/Edison/Seq/FingerSeq.hs +402/−402
src/Data/Edison/Seq/JoinList.hs +443/−443
src/Data/Edison/Seq/MyersStack.hs +453/−453
src/Data/Edison/Seq/RandList.hs +500/−500
src/Data/Edison/Seq/RevSeq.hs +399/−399
src/Data/Edison/Seq/SimpleQueue.hs +391/−391
src/Data/Edison/Seq/SizedSeq.hs +373/−373

CHANGES.md view

@@ -1,118 +1,123 @@-# Edison--Changelog of EdisonAPI and EdisonCore.--[Latest CHANGES.md](https://github.com/robdockins/edison/blob/master/CHANGES.md)--## 1.3.3.2-* Compatibility with GHC 9.10 and 9.12--## 1.3.3.1-* Remove mtl dependency (removed unnecessary imports which were incompatible with mtl 2.3)-* Fix implementation of little-endian PatriciaTrees--## 1.3.3-* Updates to handle MonadFail changes in GHC 8.x-* Updates to fix compile issues in GHC 9--## 1.3.2.1-* Fix compile problems on GHC 7.10--## 1.3.2-* Add Semigroup instances for all types that previously had Monoid instances.-* Remove use of depreciated functions in Data.Edison.Assoc.StandardMap--## 1.3.1-* Remove Arbitrary and Coarbitrary instances for Data.Set-     and Data.Map.  These are now provided by QuickCheck >= 2.8.2--## 1.3-* Updates to compile with GHC 7.10-    - Added Applicative and Alternative instances as required-    - Disambiguate the types of some operations-    - Resolve namespace clashes-* Added stack.yaml file to build with stack--## 1.2.2-  * Update edison-core to use QuickCheck version 2.*-  * Likewise update the test suite--## 1.2.1.3-* Minor fix to the StandardMap module to handle the API change in GHC 6.10--## 1.2.1.2-* Build system changes to remove mostly-superfulous dependency on-    haskell98, and to force dependence on the 1.x branch of QuickCheck.--## 1.2.1.1-* Build system changes to make GHC 6.8 and cabal >= 1.2.2 happy--## 1.2.1-* New sequence implementation based on Finger Trees-* Add the 'Measured' class to the Data.Edison.Prelude-* Addition of methods to EnumSet to project to a bit-encoded word and to-    create an EnumSet from a bit-encoded word-* Additional minor changes to EnumSet-* Fix a boneheaded mistake I made where I claimed most of Edison was-    licensed under BSD3, when it is in fact licensed under the MIT license.-    The practical differences are minor, and I hope this will not cause too-    many problems.--## 1.2.0.1-* Change use more efficient operations for StandardSet.{filterGT,filterLT}-    and StandardMap.{filterLE,filterGE,partitionLE_GT,partitionLT_GE}--## 1.2 final-* Fix documentation for sequences to reflect correct-    time complexities--## 1.2rc4-* introduce strict/strictWith operations for all APIs-* add Ord* instances for PatriciaLoMap and TernaryTrie-* add David F. Place's EnumSet implementation-* complete the FiniteMap unit test coverage and fix a bunch-    of bugs in finite map implementations-* add 'symmetricDifference' to Collection and-    Associated Collection APIs-* add Ord instances for data structures-* add Monoid instances for data structures---## 1.2rc3-* introduce the ambiguous/unambiguous concept and document-    all API operations-* factor out methods which "mirror" superclass methods and-    make them alises instead-* add lookupAndDelete* methods to associated collections-* change the type of adjustOrDelete* in associated collections-* rename subset/subsetEq to properSubset/subset-* add matching Read and Show instances for all concrete datastructures-* add properSubmap{By} submap{By} and sameMap{By} to the-    associated collection API-* add Eq instances for concrete associated collections-* break out the test suite into a separate sub-package---## 1.2rc2-* add strict variants of all folds and reduces-* reverse argument orders to 'rcons' and 'lookup*' in Sequence-* add symbolic operators for lcons, rcons, append, and lookup-    from the Sequence API-* add symbolic operators for subsetEq, difference, intersection-    and union from the set API-* rename 'single' to 'singleton' in all APIs-* reaame 'intersect' to 'intersection' in Collection and-    Associated Collection APIs-* add 'adjustOrInsert' to the Associated Collection API---## 1.2rc1-* modules re-organized into a hierarchy-* user's guide distributed throughout source code as Haddock comments-* use cabal for build system-* add Data.Edison module to re-export typeclasses-* reorder 'lookup*' and 'find*' methods for-    Collections and Associated Collections-* add 'unsafeMapMonotonic' to main Collection API-* organize QuickCheck properties into a full test suite-* add a 'structuralInvariant' method to all APIs, for unit testing+# Edison
+
+Changelog of EdisonAPI and EdisonCore.
+
+[Latest CHANGES.md](https://github.com/robdockins/edison/blob/master/CHANGES.md)
+
+## 1.3.3.3
+* Compatibility with GHC 9.14
+* Fix balance of TernaryTrie (fixes performance in pathological cases)
+* Resolve warnings and remove spurious array dependency
+
+## 1.3.3.2
+* Compatibility with GHC 9.10 and 9.12
+
+## 1.3.3.1
+* Remove mtl dependency (removed unnecessary imports which were incompatible with mtl 2.3)
+* Fix implementation of little-endian PatriciaTrees
+
+## 1.3.3
+* Updates to handle MonadFail changes in GHC 8.x
+* Updates to fix compile issues in GHC 9
+
+## 1.3.2.1
+* Fix compile problems on GHC 7.10
+
+## 1.3.2
+* Add Semigroup instances for all types that previously had Monoid instances.
+* Remove use of depreciated functions in Data.Edison.Assoc.StandardMap
+
+## 1.3.1
+* Remove Arbitrary and Coarbitrary instances for Data.Set
+     and Data.Map.  These are now provided by QuickCheck >= 2.8.2
+
+## 1.3
+* Updates to compile with GHC 7.10
+    - Added Applicative and Alternative instances as required
+    - Disambiguate the types of some operations
+    - Resolve namespace clashes
+* Added stack.yaml file to build with stack
+
+## 1.2.2
+  * Update edison-core to use QuickCheck version 2.*
+  * Likewise update the test suite
+
+## 1.2.1.3
+* Minor fix to the StandardMap module to handle the API change in GHC 6.10
+
+## 1.2.1.2
+* Build system changes to remove mostly-superfulous dependency on
+    haskell98, and to force dependence on the 1.x branch of QuickCheck.
+
+## 1.2.1.1
+* Build system changes to make GHC 6.8 and cabal >= 1.2.2 happy
+
+## 1.2.1
+* New sequence implementation based on Finger Trees
+* Add the 'Measured' class to the Data.Edison.Prelude
+* Addition of methods to EnumSet to project to a bit-encoded word and to
+    create an EnumSet from a bit-encoded word
+* Additional minor changes to EnumSet
+* Fix a boneheaded mistake I made where I claimed most of Edison was
+    licensed under BSD3, when it is in fact licensed under the MIT license.
+    The practical differences are minor, and I hope this will not cause too
+    many problems.
+
+## 1.2.0.1
+* Change use more efficient operations for StandardSet.{filterGT,filterLT}
+    and StandardMap.{filterLE,filterGE,partitionLE_GT,partitionLT_GE}
+
+## 1.2 final
+* Fix documentation for sequences to reflect correct
+    time complexities
+
+## 1.2rc4
+* introduce strict/strictWith operations for all APIs
+* add Ord* instances for PatriciaLoMap and TernaryTrie
+* add David F. Place's EnumSet implementation
+* complete the FiniteMap unit test coverage and fix a bunch
+    of bugs in finite map implementations
+* add 'symmetricDifference' to Collection and
+    Associated Collection APIs
+* add Ord instances for data structures
+* add Monoid instances for data structures
+
+
+## 1.2rc3
+* introduce the ambiguous/unambiguous concept and document
+    all API operations
+* factor out methods which "mirror" superclass methods and
+    make them alises instead
+* add lookupAndDelete* methods to associated collections
+* change the type of adjustOrDelete* in associated collections
+* rename subset/subsetEq to properSubset/subset
+* add matching Read and Show instances for all concrete datastructures
+* add properSubmap{By} submap{By} and sameMap{By} to the
+    associated collection API
+* add Eq instances for concrete associated collections
+* break out the test suite into a separate sub-package
+
+
+## 1.2rc2
+* add strict variants of all folds and reduces
+* reverse argument orders to 'rcons' and 'lookup*' in Sequence
+* add symbolic operators for lcons, rcons, append, and lookup
+    from the Sequence API
+* add symbolic operators for subsetEq, difference, intersection
+    and union from the set API
+* rename 'single' to 'singleton' in all APIs
+* reaame 'intersect' to 'intersection' in Collection and
+    Associated Collection APIs
+* add 'adjustOrInsert' to the Associated Collection API
+
+
+## 1.2rc1
+* modules re-organized into a hierarchy
+* user's guide distributed throughout source code as Haddock comments
+* use cabal for build system
+* add Data.Edison module to re-export typeclasses
+* reorder 'lookup*' and 'find*' methods for
+    Collections and Associated Collections
+* add 'unsafeMapMonotonic' to main Collection API
+* organize QuickCheck properties into a full test suite
+* add a 'structuralInvariant' method to all APIs, for unit testing

@@ -1,23 +1,25 @@-Copyright (c) 1998-1999 Chris Okasaki-Portions Copyright (c) 2002 Andrew Bromage-Portions Copyright (c) 2006-2007 Robert Dockins-Portions Copyright (c) 2006 David F. Place-Portions Copyright (c) 2006 Ross Paterson and Ralf Hinze--Permission is hereby granted, free of charge, to any person obtaining a copy-of this software and associated documentation files (the "Software"), to deal-in the Software without restriction, including without limitation the rights-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell-copies of the Software, and to permit persons to whom the Software is-furnished to do so, subject to the following conditions:--The above copyright notice and this permission notice shall be included in-all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN-THE SOFTWARE.+Copyright (c) 1998-1999 Chris Okasaki
+Portions Copyright (c) 2002 Andrew Bromage
+Portions Copyright (c) 2006-2007 Robert Dockins
+Portions Copyright (c) 2006 David F. Place
+Portions Copyright (c) 2006 Ross Paterson and Ralf Hinze
+Portions Copyright (c) 2006-2022 Robert Dockins
+Portions Copyright (c) 2022-2025 Li-yao Xia
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.

EdisonCore.cabal view

@@ -1,82 +1,81 @@-Name:           EdisonCore-Cabal-Version:  >= 1.10-Build-Type:     Simple-Version:        1.3.3.2-License:        MIT-License-File:   COPYRIGHT-Author:         Chris Okasaki-Maintainer:     robdockins AT fastmail DOT fm-Synopsis:       A library of efficient, purely-functional data structures (Core Implementations)-Category:       Data Structures-Homepage:       https://github.com/robdockins/edison-Stability:      Stable-Description:-     This package provides the core Edison data structure implementations,-     including multiple sequence, set, bag, and finite map concrete-     implementations with various performance characteristics. The-     implementations in this package have no dependencies other than those-     commonly bundled with Haskell compilers.-Extra-Source-Files: CHANGES.md---Source-Repository head-  Type: git-  Location: https://github.com/robdockins/edison/-  Subdir: edison-core--Library-  Hs-Source-Dirs: src-  Exposed-modules:-     Data.Edison.Assoc.Defaults-     Data.Edison.Assoc.AssocList-     Data.Edison.Assoc.PatriciaLoMap-     Data.Edison.Assoc.StandardMap-     Data.Edison.Assoc.TernaryTrie-     Data.Edison.Concrete.FingerTree-     Data.Edison.Coll.Defaults-     Data.Edison.Coll.LazyPairingHeap-     Data.Edison.Coll.LeftistHeap-     Data.Edison.Coll.MinHeap-     Data.Edison.Coll.SkewHeap-     Data.Edison.Coll.SplayHeap-     Data.Edison.Coll.StandardSet-     Data.Edison.Coll.EnumSet-     Data.Edison.Coll.UnbalancedSet-     Data.Edison.Seq.Defaults-     Data.Edison.Seq.BankersQueue-     Data.Edison.Seq.BinaryRandList-     Data.Edison.Seq.BraunSeq-     Data.Edison.Seq.FingerSeq-     Data.Edison.Seq.JoinList-     Data.Edison.Seq.MyersStack-     Data.Edison.Seq.RandList-     Data.Edison.Seq.RevSeq-     Data.Edison.Seq.SimpleQueue-     Data.Edison.Seq.SizedSeq-  Build-Depends:-     base >= 4.12 && < 4.22,-     QuickCheck >= 2.8.2 && < 3,-     EdisonAPI >= 1.3.3 && < 1.4,-     containers < 0.8,-     array < 0.6--  if impl(ghc < 8.0)-    Build-Depends:-      fail < 5,-      -- Provide/emulate Data.Semigroups` API for pre-GHC-8-      semigroups == 0.18.*--  Default-Language: Haskell2010-  Default-Extensions:-     MultiParamTypeClasses-     FunctionalDependencies-     UndecidableInstances-     FlexibleInstances-     CPP-     MagicHash-     ScopedTypeVariables-     GeneralizedNewtypeDeriving-     FlexibleContexts-  Ghc-Options: -funbox-strict-fields -fwarn-incomplete-patterns-  if impl(ghc >= 8.0)-    Ghc-Options:  -Wcompat+Name:           EdisonCore
+Cabal-Version:  >= 1.10
+Build-Type:     Simple
+Version:        1.3.3.3
+License:        MIT
+License-File:   COPYRIGHT
+Author:         Chris Okasaki
+Maintainer:     lysxia@gmail.com
+Synopsis:       A library of efficient, purely-functional data structures (Core Implementations)
+Category:       Data Structures
+Homepage:       https://github.com/robdockins/edison
+Stability:      Stable
+Description:
+     This package provides the core Edison data structure implementations,
+     including multiple sequence, set, bag, and finite map concrete
+     implementations with various performance characteristics. The
+     implementations in this package have no dependencies other than those
+     commonly bundled with Haskell compilers.
+Extra-Source-Files: CHANGES.md
+tested-with: GHC == 8.10.7, GHC == 9.6.7, GHC == 9.12.1, GHC == 9.14.1
+
+Source-Repository head
+  Type: git
+  Location: https://github.com/robdockins/edison/
+  Subdir: edison-core
+
+Library
+  Hs-Source-Dirs: src
+  Exposed-modules:
+     Data.Edison.Assoc.Defaults
+     Data.Edison.Assoc.AssocList
+     Data.Edison.Assoc.PatriciaLoMap
+     Data.Edison.Assoc.StandardMap
+     Data.Edison.Assoc.TernaryTrie
+     Data.Edison.Concrete.FingerTree
+     Data.Edison.Coll.Defaults
+     Data.Edison.Coll.LazyPairingHeap
+     Data.Edison.Coll.LeftistHeap
+     Data.Edison.Coll.MinHeap
+     Data.Edison.Coll.SkewHeap
+     Data.Edison.Coll.SplayHeap
+     Data.Edison.Coll.StandardSet
+     Data.Edison.Coll.EnumSet
+     Data.Edison.Coll.UnbalancedSet
+     Data.Edison.Seq.Defaults
+     Data.Edison.Seq.BankersQueue
+     Data.Edison.Seq.BinaryRandList
+     Data.Edison.Seq.BraunSeq
+     Data.Edison.Seq.FingerSeq
+     Data.Edison.Seq.JoinList
+     Data.Edison.Seq.MyersStack
+     Data.Edison.Seq.RandList
+     Data.Edison.Seq.RevSeq
+     Data.Edison.Seq.SimpleQueue
+     Data.Edison.Seq.SizedSeq
+  Build-Depends:
+     base >= 4.12 && < 4.23,
+     QuickCheck >= 2.8.2 && < 3,
+     EdisonAPI >= 1.3.3 && < 1.4,
+     containers < 0.8
+
+  if impl(ghc < 8.0)
+    Build-Depends:
+      fail < 5,
+      -- Provide/emulate Data.Semigroups` API for pre-GHC-8
+      semigroups == 0.18.*
+
+  Default-Language: Haskell2010
+  Default-Extensions:
+     MultiParamTypeClasses
+     FunctionalDependencies
+     UndecidableInstances
+     FlexibleInstances
+     CPP
+     MagicHash
+     ScopedTypeVariables
+     GeneralizedNewtypeDeriving
+     FlexibleContexts
+  Ghc-Options: -funbox-strict-fields -Wall -Wno-name-shadowing -Wno-noncanonical-monad-instances
+  if impl(ghc >= 8.0)
+    Ghc-Options: -Wcompat

src/Data/Edison/Assoc/AssocList.hs view

@@ -1,628 +1,628 @@--- |---   Module      :  Data.Edison.Assoc.AssocList---   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   This module implements finite maps as simple association lists.------   Duplicates are removed conceptually, but not physically.  The first---   occurrence of a given key is the one that is considered to be in the map.------   The list type is mildly customized to prevent boxing the pairs.--module Data.Edison.Assoc.AssocList (-    -- * Type of simple association lists-    FM, -- instance of Assoc(X), FiniteMap(X)-        -- also instance of Functor--    -- * AssocX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,-    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,-    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,-    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,-    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,--    -- * OrdAssocX operations-    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,-    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',-    foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend,-    filterLT, filterLE, filterGT, filterGE,-    partitionLT_GE, partitionLE_GT, partitionLT_GT,--    -- * Assoc operations-    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,--    -- * OrdAssoc operations-    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,-    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,--    -- * FiniteMapX operations-    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,-    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,-    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,-    properSubmap,submap,sameMap,--    -- * FiniteMap operations-    unionWithKey,unionSeqWithKey,intersectionWithKey,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)-import qualified Prelude-import Data.Monoid-import Data.Semigroup as SG-import qualified Control.Monad.Fail as Fail-import qualified Data.Edison.Assoc as A-import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.BinaryRandList as RL-import Data.Edison.Assoc.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)---- signatures for exported functions-moduleName    :: String-empty         :: Eq k => FM k a-singleton     :: Eq k => k -> a -> FM k a-fromSeq       :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a-insert        :: Eq k => k -> a -> FM k a -> FM k a-insertSeq     :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a-union         :: Eq k => FM k a -> FM k a -> FM k a-unionSeq      :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a-delete        :: Eq k => k -> FM k a -> FM k a-deleteAll     :: Eq k => k -> FM k a -> FM k a-deleteSeq     :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a-null          :: Eq k => FM k a -> Bool-size          :: Eq k => FM k a -> Int-member        :: Eq k => k -> FM k a -> Bool-count         :: Eq k => k -> FM k a -> Int-lookup        :: Eq k => k -> FM k a -> a-lookupM       :: (Eq k, Fail.MonadFail rm) => k -> FM k a -> rm a-lookupAll     :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a-lookupAndDelete    :: Eq k => k -> FM k a -> (a,FM k a)-lookupAndDeleteM   :: (Eq k, Fail.MonadFail rm)   => k -> FM k a -> rm (a,FM k a)-lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)-lookupWithDefault  :: Eq k => a -> k -> FM k a -> a-adjust             :: Eq k => (a -> a) -> k -> FM k a -> FM k a-adjustAll          :: Eq k => (a -> a) -> k -> FM k a -> FM k a-adjustOrInsert     :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustAllOrInsert  :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustOrDelete     :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a-adjustOrDeleteAll  :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a-strict             :: FM k a -> FM k a-strictWith         :: (a -> b) -> FM k a -> FM k a-map           :: Eq k => (a -> b) -> FM k a -> FM k b-fold          :: Eq k => (a -> b -> b) -> b -> FM k a -> b-fold1         :: Eq k => (a -> a -> a) -> FM k a -> a-fold'         :: Eq k => (a -> b -> b) -> b -> FM k a -> b-fold1'        :: Eq k => (a -> a -> a) -> FM k a -> a-filter        :: Eq k => (a -> Bool) -> FM k a -> FM k a-partition     :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a)-elements      :: (Eq k,S.Sequence seq) => FM k a -> seq a--fromSeqWith      :: (Eq k,S.Sequence seq) =>-                        (a -> a -> a) -> seq (k,a) -> FM k a-fromSeqWithKey   :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a-insertWith       :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a-insertWithKey    :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a-insertSeqWith    :: (Eq k,S.Sequence seq) =>-                        (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a-insertSeqWithKey :: (Eq k,S.Sequence seq) =>-                        (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a-unionl           :: Eq k => FM k a -> FM k a -> FM k a-unionr           :: Eq k => FM k a -> FM k a -> FM k a-unionWith        :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith     :: (Eq k,S.Sequence seq) =>-                        (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference       :: Eq k => FM k a -> FM k b -> FM k a-properSubset     :: Eq k => FM k a -> FM k b -> Bool-subset           :: Eq k => FM k a -> FM k b -> Bool-properSubmapBy   :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy         :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy        :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap     :: (Eq k, Eq a) => FM k a -> FM k a -> Bool-submap           :: (Eq k, Eq a) => FM k a -> FM k a -> Bool-sameMap          :: (Eq k, Eq a) => FM k a -> FM k a -> Bool--toSeq            :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a)-keys             :: (Eq k,S.Sequence seq) => FM k a -> seq k-mapWithKey       :: Eq k => (k -> a -> b) -> FM k a -> FM k b-foldWithKey      :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldWithKey'     :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-filterWithKey    :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a-partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a)--unionWithKey     :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey  :: (Eq k,S.Sequence seq) =>-                        (k -> a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c--minView          :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a)-minElem          :: Ord k => FM k a -> a-deleteMin        :: Ord k => FM k a -> FM k a-unsafeInsertMin  :: Ord k => k -> a -> FM k a -> FM k a-maxView          :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a)-maxElem          :: Ord k => FM k a -> a-deleteMax        :: Ord k => FM k a -> FM k a-unsafeInsertMax  :: Ord k => k -> a -> FM k a -> FM k a-foldr            :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1           :: Ord k => (a -> a -> a) -> FM k a -> a-foldl            :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldl1           :: Ord k => (a -> a -> a) -> FM k a -> a-foldr'           :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1'          :: Ord k => (a -> a -> a) -> FM k a -> a-foldl'           :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldl1'          :: Ord k => (a -> a -> a) -> FM k a -> a-unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-unsafeAppend     :: Ord k => FM k a -> FM k a -> FM k a-filterLT         :: Ord k => k -> FM k a -> FM k a-filterLE         :: Ord k => k -> FM k a -> FM k a-filterGT         :: Ord k => k -> FM k a -> FM k a-filterGE         :: Ord k => k -> FM k a -> FM k a-partitionLT_GE   :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLE_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLT_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)--minViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)-minElemWithKey    :: Ord k => FM k a -> (k,a)-maxViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)-maxElemWithKey    :: Ord k => FM k a -> (k,a)-foldrWithKey      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey      :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b-foldrWithKey'     :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey'     :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b-toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)---moduleName = "Data.Edison.Assoc.AssocList"---data FM k a = E | I k a (FM k a)---- no invariants-structuralInvariant :: Eq k => FM k a -> Bool-structuralInvariant = const True-------------------------------------------- some unexported utility functions---- uncurried insert.-uinsert :: (t, t1) -> FM t t1 -> FM t t1-uinsert (k,x) = I k x----- left biased merge.-mergeFM :: (Ord t) => FM t t1 -> FM t t1 -> FM t t1-mergeFM E m = m-mergeFM m E = m-mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) =-  case compare k1 k2 of-      LT -> I k1 a1 (mergeFM m1 o2)-      GT -> I k2 a2 (mergeFM o1 m2)-      EQ -> I k1 a1 (mergeFM m1 m2)--toRandList :: FM t t1 -> RL.Seq (FM t t1)-toRandList E = RL.empty-toRandList (I k a m) = RL.lcons (I k a E) (toRandList m)--mergeSortFM :: (Ord t) => FM t t1 -> FM t t1-mergeSortFM m = RL.reducer mergeFM E (toRandList m)--foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b-foldrFM _ z E = z-foldrFM f z (I k a m) = f a (foldrFM f z (delete k m))--foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a-foldr1FM _ (I _ a E) = a-foldr1FM f (I k a m) = f a (foldr1FM f (delete k m))-foldr1FM _ _ = error "invalid call to foldr1FM on empty map"--foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b-foldrFM' _ z E = z-foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m))--foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a-foldr1FM' _ (I _ a E) = a-foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m))-foldr1FM' _ _ = error "invalid call to foldr1FM' on empty map"--foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b-foldlFM _ x E = x-foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m)--foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b-foldlFM' _ x E = x-foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m)--foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldrWithKeyFM _ z E = z-foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m))--foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldrWithKeyFM' _ z E = z-foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m))--foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b-foldlWithKeyFM _ x E = x-foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m)--foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b-foldlWithKeyFM' _ x E = x-foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m)--takeWhileFM :: (k -> Bool) -> FM k a -> FM k a-takeWhileFM _ E = E-takeWhileFM p (I k a m)-   | p k       = I k a (takeWhileFM p m)-   | otherwise = E--dropWhileFM :: (k -> Bool) -> FM k a -> FM k a-dropWhileFM _ E = E-dropWhileFM p o@(I k _ m)-   | p k       = dropWhileFM p m-   | otherwise = o--spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a)-spanFM _ E = (E,E)-spanFM p o@(I k a m)-   | p k       = let (x,y) = spanFM p m in (I k a x,y)-   | otherwise = (E,o)--------------------------------------------------------- interface functions--empty = E-singleton k x = I k x E-insert = I-insertSeq kxs m = S.foldr uinsert m kxs-fromSeq = S.foldr uinsert E--union m E = m-union E m = m-union (I k x m1) m2 = I k x (union m1 m2)--unionSeq = S.foldr union E--deleteAll _ E = E-deleteAll key (I k x m) | key == k  = deleteAll key m-                        | otherwise = I k x (deleteAll key m)--delete = deleteAll--null E = True-null (I _ _ _) = False--size E = 0-size (I k _ m) = 1 + size (delete k m)--member _ E = False-member key (I k _ m) = key == k || member key m--count _ E = 0-count key (I k _ m) | key == k  = 1-                    | otherwise = count key m--lookup key m = runFail_ (lookupM key m)--lookupM _ E = fail "AssocList.lookup: lookup failed"-lookupM key (I k x m) | key == k  = return x-                      | otherwise = lookupM key m--lookupAll _ E = S.empty-lookupAll key (I k x m) | key == k  = S.singleton x-                        | otherwise = lookupAll key m--lookupAndDelete key m = runFail_ (lookupAndDeleteM key m)--lookupAndDeleteM _ E = fail "AssocList.lookupAndDeleteM: lookup failed"-lookupAndDeleteM key (I k x m)-   | key == k  = return (x,delete k m)-   | otherwise = lookupAndDeleteM key m >>=-                    \ (z, m') -> return (z, I k x m')--lookupAndDeleteAll key m =-   case lookupAndDeleteM key m of-      Nothing     -> (S.empty,m)-      Just (z,m') -> (S.singleton z,m')---lookupWithDefault d _ E = d-lookupWithDefault d key (I k x m) | key == k = x-                                  | otherwise = lookupWithDefault d key m--elements E = S.empty-elements (I k x m) = S.lcons x (elements (delete k m))--adjust _ _ E = E-adjust f key (I k x m) | key == k  = I key (f x) m-                       | otherwise = I k x (adjust f key m)--adjustAll = adjust--adjustOrInsert _ z key E = singleton key z-adjustOrInsert f z key (I k x m)-    | key == k  = I key (f x) m-    | otherwise = I k x (adjustOrInsert f z key m)--adjustAllOrInsert = adjustOrInsert--adjustOrDelete = adjustOrDeleteDefault-adjustOrDeleteAll = adjustOrDeleteAllDefault--map _ E = E-map f (I k x m) = I k (f x) (map f m)--fold _ c E = c-fold f c (I k x m) = fold f (f x c) (delete k m)--fold' _ c E = c-fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m)--fold1 _ E = error "AssocList.fold1: empty map"-fold1 f (I k x m) = fold f x (delete k m)--fold1' _ E = error "AssocList.fold1': empty map"-fold1' f (I k x m) = fold' f x (delete k m)--filter _ E = E-filter p (I k x m) | p x = I k x (filter p (delete k m))-                   | otherwise = filter p (delete k m)--partition _ E = (E, E)-partition p (I k x m)-    | p x       = (I k x m1,m2)-    | otherwise = (m1,I k x m2)-  where (m1,m2) = partition p (delete k m)---toSeq E = S.empty-toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m))--keys E = S.empty-keys (I k _ m) = S.lcons k (keys (delete k m))--mapWithKey _ E = E-mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m)--foldWithKey _ c E = c-foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m)--foldWithKey' _ c E = c-foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m)--filterWithKey _ E = E-filterWithKey p (I k x m)-    | p k x = I k x (filterWithKey p (delete k m))-    | otherwise = filterWithKey p (delete k m)--partitionWithKey _ E = (E, E)-partitionWithKey p (I k x m)-    | p k x     = (I k x m1,m2)-    | otherwise = (m1,I k x m2)-  where (m1,m2) = partitionWithKey p (delete k m)--unionl = union-unionr = flip union---findMin :: (Ord t) => t -> t1 -> FM t t1 -> (t, t1)-findMin k0 x E = (k0,x)-findMin k0 a0 (I k a m)-        | k < k0    = findMin k  a  (delete k m)-        | otherwise = findMin k0 a0 (delete k m)--findMax ::( Ord t) => t -> t1 -> FM t t1 -> (t, t1)-findMax k0 x E = (k0,x)-findMax k0 a0 (I k a m)-        | k > k0    = findMax k  a  (delete k m)-        | otherwise = findMax k0 a0 (delete k m)--minView E = fail (moduleName++".minView: empty map")-minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n)--minElem E = error (moduleName++".minElem: empty map")-minElem (I k a m) = let (_,x) = findMin k a m in x--deleteMin E = error (moduleName++".deleteMin: empty map")-deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n--unsafeInsertMin  = insert--maxView E = fail (moduleName++".maxView: empty map")-maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n)--maxElem E = error (moduleName++".maxElem: empty map")-maxElem (I k a m) = let (_,x) = findMax k a m in x--deleteMax E = error (moduleName++".deleteMax: empty map")-deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n--unsafeInsertMax = insert--foldr  f z m = foldrFM  f z (mergeSortFM m)-foldr' f z m = foldrFM' f z (mergeSortFM m)--foldr1 f m =-  case mergeSortFM m of-    E -> error $ moduleName++".foldlr1: empty map"-    n -> foldr1FM f n--foldr1' f m =-  case mergeSortFM m of-    E -> error $ moduleName++".foldlr1': empty map"-    n -> foldr1FM' f n--foldl  f x m = foldlFM  f x (mergeSortFM m)-foldl' f x m = foldlFM' f x (mergeSortFM m)--foldl1 f m =-  case mergeSortFM m of-    E -> error $ moduleName++".foldl1: empty map"-    I k a n -> foldlFM f a (delete k n)--foldl1' f m =-  case mergeSortFM m of-    E -> error $ moduleName++".foldl1': empty map"-    I k a n -> foldlFM' f a (delete k n)--unsafeFromOrdSeq   = fromSeq-unsafeAppend       = union-filterLT k         = takeWhileFM (<k)  . mergeSortFM-filterLE k         = takeWhileFM (<=k) . mergeSortFM-filterGT k         = dropWhileFM (<=k) . mergeSortFM-filterGE k         = dropWhileFM (<k)  . mergeSortFM-partitionLT_GE k   = spanFM (<k)  . mergeSortFM-partitionLE_GT k   = spanFM (<=k) . mergeSortFM-partitionLT_GT k   = (\(x,y) -> (x,delete k y)) . spanFM (<k)  . mergeSortFM--minViewWithKey E   = fail $ moduleName++".minViewWithKey: empty map"-minViewWithKey n@(I k a m) = let (k',x) = findMin k a m in return ((k',x),delete k' n)--minElemWithKey E   = error $ moduleName++".minElemWithKey: empty map"-minElemWithKey (I k a m) = findMin k a m--maxViewWithKey E   = fail $ moduleName++".maxViewWithKey: empty map"-maxViewWithKey n@(I k a m) = let (k',x) = findMax k a m in return ((k',x),delete k' n)--maxElemWithKey E   = error $ moduleName++".maxElemWithKey: empty map"-maxElemWithKey (I k a m) = findMax k a m--foldrWithKey  f z   = foldrWithKeyFM  f z . mergeSortFM-foldrWithKey' f z   = foldrWithKeyFM' f z . mergeSortFM-foldlWithKey  f x   = foldlWithKeyFM  f x . mergeSortFM-foldlWithKey' f x   = foldlWithKeyFM' f x . mergeSortFM-toOrdSeq            = toSeq . mergeSortFM---strict n@E = n-strict n@(I _ _ m) = strict m `seq` n--strictWith _ n@E = n-strictWith f n@(I _ a m) = f a `seq` strictWith f m `seq` n----- defaults--deleteSeq = deleteSeqUsingFoldr-insertWith = insertWithUsingLookupM-insertSeqWith = insertSeqWithUsingInsertWith-insertWithKey = insertWithKeyUsingInsertWith-insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey-unionWith = unionWithUsingInsertWith-unionSeqWith = unionSeqWithUsingFoldr-fromSeqWith = fromSeqWithUsingInsertSeqWith-fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey-intersectionWith = intersectionWithUsingLookupM-difference = differenceUsingDelete-properSubset = properSubsetUsingSubset-subset = subsetUsingMember-properSubmapBy = properSubmapByUsingSubmapBy-submapBy = submapByUsingLookupM-sameMapBy = sameMapByUsingSubmapBy-properSubmap = A.properSubmap-submap = A.submap-sameMap = A.sameMap-unionWithKey = unionWithKeyUsingInsertWithKey-unionSeqWithKey = unionSeqWithKeyUsingFoldr-intersectionWithKey = intersectionWithKeyUsingLookupM---- instance declarations--instance Eq k  => A.AssocX (FM k) k where-  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; union = union; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;-   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;-   lookupAndDeleteAll = lookupAndDeleteAll;-   lookupWithDefault = lookupWithDefault; adjust = adjust;-   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;-   adjustAllOrInsert = adjustAllOrInsert;-   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; elements = elements;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k => A.OrdAssocX (FM k) k where-  {minView = minView; minElem = minElem; deleteMin = deleteMin;-   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;-   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Eq k => A.FiniteMapX (FM k) k where-  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;-   insertWith  = insertWith; insertWithKey = insertWithKey;-   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;-   unionl = unionl; unionr = unionr; unionWith = unionWith;-   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;-   difference = difference; properSubset = properSubset; subset = subset;-   properSubmapBy = properSubmapBy; submapBy = submapBy;-   sameMapBy = sameMapBy}--instance Ord k => A.OrdFiniteMapX (FM k) k--instance Eq k  => A.Assoc (FM k) k where-  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;-   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';-   filterWithKey = filterWithKey;-   partitionWithKey = partitionWithKey}--instance Ord k => A.OrdAssoc (FM k) k where-  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;-   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;-   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';-   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';-   toOrdSeq = toOrdSeq}--instance Eq k => A.FiniteMap (FM k) k where-  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;-   intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdFiniteMap (FM k) k--instance Eq k => Functor (FM k) where-  fmap =  map--instance (Eq k,Eq a) => Eq (FM k a) where-  (==) = sameMap--instance (Ord k, Ord a) => Ord (FM k a) where-  compare = compareUsingToOrdList--instance (Eq k,Show k,Show a) => Show (FM k a) where-  showsPrec = showsPrecUsingToList--instance (Eq k,Read k,Read a) => Read (FM k a) where-  readsPrec = readsPrecUsingFromList--instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where-   arbitrary = do (xs::[(k,a)]) <- arbitrary-                  return (Prelude.foldr (uncurry insert) empty xs)--instance (Eq k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where-   coarbitrary E = variant 0-   coarbitrary (I k a m) = variant 1 . coarbitrary k-                         . coarbitrary a . coarbitrary m---instance Eq k => Semigroup (FM k a) where-   (<>) = union-instance Eq k => Monoid (FM k a) where-   mempty  = empty-   mappend = (SG.<>)-   mconcat = unionSeq+-- |
+--   Module      :  Data.Edison.Assoc.AssocList
+--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module implements finite maps as simple association lists.
+--
+--   Duplicates are removed conceptually, but not physically.  The first
+--   occurrence of a given key is the one that is considered to be in the map.
+--
+--   The list type is mildly customized to prevent boxing the pairs.
+
+module Data.Edison.Assoc.AssocList (
+    -- * Type of simple association lists
+    FM, -- instance of Assoc(X), FiniteMap(X)
+        -- also instance of Functor
+
+    -- * AssocX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,
+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,
+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,
+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,
+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,
+
+    -- * OrdAssocX operations
+    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,
+    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',
+    foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend,
+    filterLT, filterLE, filterGT, filterGE,
+    partitionLT_GE, partitionLE_GT, partitionLT_GT,
+
+    -- * Assoc operations
+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,
+
+    -- * OrdAssoc operations
+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,
+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,
+
+    -- * FiniteMapX operations
+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,
+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,
+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,
+    properSubmap,submap,sameMap,
+
+    -- * FiniteMap operations
+    unionWithKey,unionSeqWithKey,intersectionWithKey,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
+import qualified Prelude
+import Data.Monoid
+import Data.Semigroup as SG
+import qualified Control.Monad.Fail as Fail
+import qualified Data.Edison.Assoc as A
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.BinaryRandList as RL
+import Data.Edison.Assoc.Defaults
+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)
+
+-- signatures for exported functions
+moduleName    :: String
+empty         :: Eq k => FM k a
+singleton     :: Eq k => k -> a -> FM k a
+fromSeq       :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a
+insert        :: Eq k => k -> a -> FM k a -> FM k a
+insertSeq     :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a
+union         :: Eq k => FM k a -> FM k a -> FM k a
+unionSeq      :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a
+delete        :: Eq k => k -> FM k a -> FM k a
+deleteAll     :: Eq k => k -> FM k a -> FM k a
+deleteSeq     :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a
+null          :: Eq k => FM k a -> Bool
+size          :: Eq k => FM k a -> Int
+member        :: Eq k => k -> FM k a -> Bool
+count         :: Eq k => k -> FM k a -> Int
+lookup        :: Eq k => k -> FM k a -> a
+lookupM       :: (Eq k, Fail.MonadFail rm) => k -> FM k a -> rm a
+lookupAll     :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a
+lookupAndDelete    :: Eq k => k -> FM k a -> (a,FM k a)
+lookupAndDeleteM   :: (Eq k, Fail.MonadFail rm)   => k -> FM k a -> rm (a,FM k a)
+lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)
+lookupWithDefault  :: Eq k => a -> k -> FM k a -> a
+adjust             :: Eq k => (a -> a) -> k -> FM k a -> FM k a
+adjustAll          :: Eq k => (a -> a) -> k -> FM k a -> FM k a
+adjustOrInsert     :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a
+adjustAllOrInsert  :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a
+adjustOrDelete     :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a
+adjustOrDeleteAll  :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a
+strict             :: FM k a -> FM k a
+strictWith         :: (a -> b) -> FM k a -> FM k a
+map           :: Eq k => (a -> b) -> FM k a -> FM k b
+fold          :: Eq k => (a -> b -> b) -> b -> FM k a -> b
+fold1         :: Eq k => (a -> a -> a) -> FM k a -> a
+fold'         :: Eq k => (a -> b -> b) -> b -> FM k a -> b
+fold1'        :: Eq k => (a -> a -> a) -> FM k a -> a
+filter        :: Eq k => (a -> Bool) -> FM k a -> FM k a
+partition     :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a)
+elements      :: (Eq k,S.Sequence seq) => FM k a -> seq a
+
+fromSeqWith      :: (Eq k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq (k,a) -> FM k a
+fromSeqWithKey   :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a
+insertWith       :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a
+insertWithKey    :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a
+insertSeqWith    :: (Eq k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a
+insertSeqWithKey :: (Eq k,S.Sequence seq) =>
+                        (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a
+unionl           :: Eq k => FM k a -> FM k a -> FM k a
+unionr           :: Eq k => FM k a -> FM k a -> FM k a
+unionWith        :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWith     :: (Eq k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq (FM k a) -> FM k a
+intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c
+difference       :: Eq k => FM k a -> FM k b -> FM k a
+properSubset     :: Eq k => FM k a -> FM k b -> Bool
+subset           :: Eq k => FM k a -> FM k b -> Bool
+properSubmapBy   :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+submapBy         :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+sameMapBy        :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+properSubmap     :: (Eq k, Eq a) => FM k a -> FM k a -> Bool
+submap           :: (Eq k, Eq a) => FM k a -> FM k a -> Bool
+sameMap          :: (Eq k, Eq a) => FM k a -> FM k a -> Bool
+
+toSeq            :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a)
+keys             :: (Eq k,S.Sequence seq) => FM k a -> seq k
+mapWithKey       :: Eq k => (k -> a -> b) -> FM k a -> FM k b
+foldWithKey      :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldWithKey'     :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b
+filterWithKey    :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a
+partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a)
+
+unionWithKey     :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWithKey  :: (Eq k,S.Sequence seq) =>
+                        (k -> a -> a -> a) -> seq (FM k a) -> FM k a
+intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c
+
+minView          :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a)
+minElem          :: Ord k => FM k a -> a
+deleteMin        :: Ord k => FM k a -> FM k a
+unsafeInsertMin  :: Ord k => k -> a -> FM k a -> FM k a
+maxView          :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a)
+maxElem          :: Ord k => FM k a -> a
+deleteMax        :: Ord k => FM k a -> FM k a
+unsafeInsertMax  :: Ord k => k -> a -> FM k a -> FM k a
+foldr            :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldr1           :: Ord k => (a -> a -> a) -> FM k a -> a
+foldl            :: Ord k => (b -> a -> b) -> b -> FM k a -> b
+foldl1           :: Ord k => (a -> a -> a) -> FM k a -> a
+foldr'           :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldr1'          :: Ord k => (a -> a -> a) -> FM k a -> a
+foldl'           :: Ord k => (b -> a -> b) -> b -> FM k a -> b
+foldl1'          :: Ord k => (a -> a -> a) -> FM k a -> a
+unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a
+unsafeAppend     :: Ord k => FM k a -> FM k a -> FM k a
+filterLT         :: Ord k => k -> FM k a -> FM k a
+filterLE         :: Ord k => k -> FM k a -> FM k a
+filterGT         :: Ord k => k -> FM k a -> FM k a
+filterGE         :: Ord k => k -> FM k a -> FM k a
+partitionLT_GE   :: Ord k => k -> FM k a -> (FM k a,FM k a)
+partitionLE_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)
+partitionLT_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)
+
+minViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)
+minElemWithKey    :: Ord k => FM k a -> (k,a)
+maxViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)
+maxElemWithKey    :: Ord k => FM k a -> (k,a)
+foldrWithKey      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldlWithKey      :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b
+foldrWithKey'     :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldlWithKey'     :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b
+toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)
+
+
+moduleName = "Data.Edison.Assoc.AssocList"
+
+
+data FM k a = E | I k a (FM k a)
+
+-- no invariants
+structuralInvariant :: Eq k => FM k a -> Bool
+structuralInvariant = const True
+
+---------------------------------------
+-- some unexported utility functions
+
+-- uncurried insert.
+uinsert :: (t, t1) -> FM t t1 -> FM t t1
+uinsert (k,x) = I k x
+
+
+-- left biased merge.
+mergeFM :: (Ord t) => FM t t1 -> FM t t1 -> FM t t1
+mergeFM E m = m
+mergeFM m E = m
+mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) =
+  case compare k1 k2 of
+      LT -> I k1 a1 (mergeFM m1 o2)
+      GT -> I k2 a2 (mergeFM o1 m2)
+      EQ -> I k1 a1 (mergeFM m1 m2)
+
+toRandList :: FM t t1 -> RL.Seq (FM t t1)
+toRandList E = RL.empty
+toRandList (I k a m) = RL.lcons (I k a E) (toRandList m)
+
+mergeSortFM :: (Ord t) => FM t t1 -> FM t t1
+mergeSortFM m = RL.reducer mergeFM E (toRandList m)
+
+foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b
+foldrFM _ z E = z
+foldrFM f z (I k a m) = f a (foldrFM f z (delete k m))
+
+foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a
+foldr1FM _ (I _ a E) = a
+foldr1FM f (I k a m) = f a (foldr1FM f (delete k m))
+foldr1FM _ _ = error "invalid call to foldr1FM on empty map"
+
+foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b
+foldrFM' _ z E = z
+foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m))
+
+foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a
+foldr1FM' _ (I _ a E) = a
+foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m))
+foldr1FM' _ _ = error "invalid call to foldr1FM' on empty map"
+
+foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b
+foldlFM _ x E = x
+foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m)
+
+foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b
+foldlFM' _ x E = x
+foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m)
+
+foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldrWithKeyFM _ z E = z
+foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m))
+
+foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldrWithKeyFM' _ z E = z
+foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m))
+
+foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b
+foldlWithKeyFM _ x E = x
+foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m)
+
+foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b
+foldlWithKeyFM' _ x E = x
+foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m)
+
+takeWhileFM :: (k -> Bool) -> FM k a -> FM k a
+takeWhileFM _ E = E
+takeWhileFM p (I k a m)
+   | p k       = I k a (takeWhileFM p m)
+   | otherwise = E
+
+dropWhileFM :: (k -> Bool) -> FM k a -> FM k a
+dropWhileFM _ E = E
+dropWhileFM p o@(I k _ m)
+   | p k       = dropWhileFM p m
+   | otherwise = o
+
+spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a)
+spanFM _ E = (E,E)
+spanFM p o@(I k a m)
+   | p k       = let (x,y) = spanFM p m in (I k a x,y)
+   | otherwise = (E,o)
+
+
+---------------------------------------------------
+-- interface functions
+
+empty = E
+singleton k x = I k x E
+insert = I
+insertSeq kxs m = S.foldr uinsert m kxs
+fromSeq = S.foldr uinsert E
+
+union m E = m
+union E m = m
+union (I k x m1) m2 = I k x (union m1 m2)
+
+unionSeq = S.foldr union E
+
+deleteAll _ E = E
+deleteAll key (I k x m) | key == k  = deleteAll key m
+                        | otherwise = I k x (deleteAll key m)
+
+delete = deleteAll
+
+null E = True
+null (I _ _ _) = False
+
+size E = 0
+size (I k _ m) = 1 + size (delete k m)
+
+member _ E = False
+member key (I k _ m) = key == k || member key m
+
+count _ E = 0
+count key (I k _ m) | key == k  = 1
+                    | otherwise = count key m
+
+lookup key m = runFail_ (lookupM key m)
+
+lookupM _ E = fail "AssocList.lookup: lookup failed"
+lookupM key (I k x m) | key == k  = return x
+                      | otherwise = lookupM key m
+
+lookupAll _ E = S.empty
+lookupAll key (I k x m) | key == k  = S.singleton x
+                        | otherwise = lookupAll key m
+
+lookupAndDelete key m = runFail_ (lookupAndDeleteM key m)
+
+lookupAndDeleteM _ E = fail "AssocList.lookupAndDeleteM: lookup failed"
+lookupAndDeleteM key (I k x m)
+   | key == k  = return (x,delete k m)
+   | otherwise = lookupAndDeleteM key m >>=
+                    \ (z, m') -> return (z, I k x m')
+
+lookupAndDeleteAll key m =
+   case lookupAndDeleteM key m of
+      Nothing     -> (S.empty,m)
+      Just (z,m') -> (S.singleton z,m')
+
+
+lookupWithDefault d _ E = d
+lookupWithDefault d key (I k x m) | key == k = x
+                                  | otherwise = lookupWithDefault d key m
+
+elements E = S.empty
+elements (I k x m) = S.lcons x (elements (delete k m))
+
+adjust _ _ E = E
+adjust f key (I k x m) | key == k  = I key (f x) m
+                       | otherwise = I k x (adjust f key m)
+
+adjustAll = adjust
+
+adjustOrInsert _ z key E = singleton key z
+adjustOrInsert f z key (I k x m)
+    | key == k  = I key (f x) m
+    | otherwise = I k x (adjustOrInsert f z key m)
+
+adjustAllOrInsert = adjustOrInsert
+
+adjustOrDelete = adjustOrDeleteDefault
+adjustOrDeleteAll = adjustOrDeleteAllDefault
+
+map _ E = E
+map f (I k x m) = I k (f x) (map f m)
+
+fold _ c E = c
+fold f c (I k x m) = fold f (f x c) (delete k m)
+
+fold' _ c E = c
+fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m)
+
+fold1 _ E = error "AssocList.fold1: empty map"
+fold1 f (I k x m) = fold f x (delete k m)
+
+fold1' _ E = error "AssocList.fold1': empty map"
+fold1' f (I k x m) = fold' f x (delete k m)
+
+filter _ E = E
+filter p (I k x m) | p x = I k x (filter p (delete k m))
+                   | otherwise = filter p (delete k m)
+
+partition _ E = (E, E)
+partition p (I k x m)
+    | p x       = (I k x m1,m2)
+    | otherwise = (m1,I k x m2)
+  where (m1,m2) = partition p (delete k m)
+
+
+toSeq E = S.empty
+toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m))
+
+keys E = S.empty
+keys (I k _ m) = S.lcons k (keys (delete k m))
+
+mapWithKey _ E = E
+mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m)
+
+foldWithKey _ c E = c
+foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m)
+
+foldWithKey' _ c E = c
+foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m)
+
+filterWithKey _ E = E
+filterWithKey p (I k x m)
+    | p k x = I k x (filterWithKey p (delete k m))
+    | otherwise = filterWithKey p (delete k m)
+
+partitionWithKey _ E = (E, E)
+partitionWithKey p (I k x m)
+    | p k x     = (I k x m1,m2)
+    | otherwise = (m1,I k x m2)
+  where (m1,m2) = partitionWithKey p (delete k m)
+
+unionl = union
+unionr = flip union
+
+
+findMin :: (Ord t) => t -> t1 -> FM t t1 -> (t, t1)
+findMin k0 x E = (k0,x)
+findMin k0 a0 (I k a m)
+        | k < k0    = findMin k  a  (delete k m)
+        | otherwise = findMin k0 a0 (delete k m)
+
+findMax ::( Ord t) => t -> t1 -> FM t t1 -> (t, t1)
+findMax k0 x E = (k0,x)
+findMax k0 a0 (I k a m)
+        | k > k0    = findMax k  a  (delete k m)
+        | otherwise = findMax k0 a0 (delete k m)
+
+minView E = fail (moduleName++".minView: empty map")
+minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n)
+
+minElem E = error (moduleName++".minElem: empty map")
+minElem (I k a m) = let (_,x) = findMin k a m in x
+
+deleteMin E = error (moduleName++".deleteMin: empty map")
+deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n
+
+unsafeInsertMin  = insert
+
+maxView E = fail (moduleName++".maxView: empty map")
+maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n)
+
+maxElem E = error (moduleName++".maxElem: empty map")
+maxElem (I k a m) = let (_,x) = findMax k a m in x
+
+deleteMax E = error (moduleName++".deleteMax: empty map")
+deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n
+
+unsafeInsertMax = insert
+
+foldr  f z m = foldrFM  f z (mergeSortFM m)
+foldr' f z m = foldrFM' f z (mergeSortFM m)
+
+foldr1 f m =
+  case mergeSortFM m of
+    E -> error $ moduleName++".foldlr1: empty map"
+    n -> foldr1FM f n
+
+foldr1' f m =
+  case mergeSortFM m of
+    E -> error $ moduleName++".foldlr1': empty map"
+    n -> foldr1FM' f n
+
+foldl  f x m = foldlFM  f x (mergeSortFM m)
+foldl' f x m = foldlFM' f x (mergeSortFM m)
+
+foldl1 f m =
+  case mergeSortFM m of
+    E -> error $ moduleName++".foldl1: empty map"
+    I k a n -> foldlFM f a (delete k n)
+
+foldl1' f m =
+  case mergeSortFM m of
+    E -> error $ moduleName++".foldl1': empty map"
+    I k a n -> foldlFM' f a (delete k n)
+
+unsafeFromOrdSeq   = fromSeq
+unsafeAppend       = union
+filterLT k         = takeWhileFM (<k)  . mergeSortFM
+filterLE k         = takeWhileFM (<=k) . mergeSortFM
+filterGT k         = dropWhileFM (<=k) . mergeSortFM
+filterGE k         = dropWhileFM (<k)  . mergeSortFM
+partitionLT_GE k   = spanFM (<k)  . mergeSortFM
+partitionLE_GT k   = spanFM (<=k) . mergeSortFM
+partitionLT_GT k   = (\(x,y) -> (x,delete k y)) . spanFM (<k)  . mergeSortFM
+
+minViewWithKey E   = fail $ moduleName++".minViewWithKey: empty map"
+minViewWithKey n@(I k a m) = let (k',x) = findMin k a m in return ((k',x),delete k' n)
+
+minElemWithKey E   = error $ moduleName++".minElemWithKey: empty map"
+minElemWithKey (I k a m) = findMin k a m
+
+maxViewWithKey E   = fail $ moduleName++".maxViewWithKey: empty map"
+maxViewWithKey n@(I k a m) = let (k',x) = findMax k a m in return ((k',x),delete k' n)
+
+maxElemWithKey E   = error $ moduleName++".maxElemWithKey: empty map"
+maxElemWithKey (I k a m) = findMax k a m
+
+foldrWithKey  f z   = foldrWithKeyFM  f z . mergeSortFM
+foldrWithKey' f z   = foldrWithKeyFM' f z . mergeSortFM
+foldlWithKey  f x   = foldlWithKeyFM  f x . mergeSortFM
+foldlWithKey' f x   = foldlWithKeyFM' f x . mergeSortFM
+toOrdSeq            = toSeq . mergeSortFM
+
+
+strict n@E = n
+strict n@(I _ _ m) = strict m `seq` n
+
+strictWith _ n@E = n
+strictWith f n@(I _ a m) = f a `seq` strictWith f m `seq` n
+
+
+-- defaults
+
+deleteSeq = deleteSeqUsingFoldr
+insertWith = insertWithUsingLookupM
+insertSeqWith = insertSeqWithUsingInsertWith
+insertWithKey = insertWithKeyUsingInsertWith
+insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey
+unionWith = unionWithUsingInsertWith
+unionSeqWith = unionSeqWithUsingFoldr
+fromSeqWith = fromSeqWithUsingInsertSeqWith
+fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey
+intersectionWith = intersectionWithUsingLookupM
+difference = differenceUsingDelete
+properSubset = properSubsetUsingSubset
+subset = subsetUsingMember
+properSubmapBy = properSubmapByUsingSubmapBy
+submapBy = submapByUsingLookupM
+sameMapBy = sameMapByUsingSubmapBy
+properSubmap = A.properSubmap
+submap = A.submap
+sameMap = A.sameMap
+unionWithKey = unionWithKeyUsingInsertWithKey
+unionSeqWithKey = unionSeqWithKeyUsingFoldr
+intersectionWithKey = intersectionWithKeyUsingLookupM
+
+-- instance declarations
+
+instance Eq k  => A.AssocX (FM k) k where
+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; union = union; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;
+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;
+   lookupAndDeleteAll = lookupAndDeleteAll;
+   lookupWithDefault = lookupWithDefault; adjust = adjust;
+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;
+   adjustAllOrInsert = adjustAllOrInsert;
+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; elements = elements;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord k => A.OrdAssocX (FM k) k where
+  {minView = minView; minElem = minElem; deleteMin = deleteMin;
+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;
+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Eq k => A.FiniteMapX (FM k) k where
+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;
+   insertWith  = insertWith; insertWithKey = insertWithKey;
+   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;
+   unionl = unionl; unionr = unionr; unionWith = unionWith;
+   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;
+   difference = difference; properSubset = properSubset; subset = subset;
+   properSubmapBy = properSubmapBy; submapBy = submapBy;
+   sameMapBy = sameMapBy}
+
+instance Ord k => A.OrdFiniteMapX (FM k) k
+
+instance Eq k  => A.Assoc (FM k) k where
+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;
+   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';
+   filterWithKey = filterWithKey;
+   partitionWithKey = partitionWithKey}
+
+instance Ord k => A.OrdAssoc (FM k) k where
+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;
+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;
+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';
+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';
+   toOrdSeq = toOrdSeq}
+
+instance Eq k => A.FiniteMap (FM k) k where
+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;
+   intersectionWithKey = intersectionWithKey}
+
+instance Ord k => A.OrdFiniteMap (FM k) k
+
+instance Eq k => Functor (FM k) where
+  fmap =  map
+
+instance (Eq k,Eq a) => Eq (FM k a) where
+  (==) = sameMap
+
+instance (Ord k, Ord a) => Ord (FM k a) where
+  compare = compareUsingToOrdList
+
+instance (Eq k,Show k,Show a) => Show (FM k a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Eq k,Read k,Read a) => Read (FM k a) where
+  readsPrec = readsPrecUsingFromList
+
+instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where
+   arbitrary = do (xs::[(k,a)]) <- arbitrary
+                  return (Prelude.foldr (uncurry insert) empty xs)
+
+instance (Eq k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where
+   coarbitrary E = variant (0 :: Int)
+   coarbitrary (I k a m) = variant (1 :: Int) . coarbitrary k
+                         . coarbitrary a . coarbitrary m
+
+
+instance Eq k => Semigroup (FM k a) where
+   (<>) = union
+instance Eq k => Monoid (FM k a) where
+   mempty  = empty
+   mappend = (SG.<>)
+   mconcat = unionSeq

src/Data/Edison/Assoc/Defaults.hs view

@@ -1,311 +1,315 @@--- |---   Module      :  Data.Edison.Assoc.Defaults---   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  internal (unstable)---   Portability :  GHC, Hugs (MPTC and FD)------   This module provides default implementations of many of the associative---   collection operations.  These function are used to fill in collection---   implementations and are not intended to be used directly by end users.--module Data.Edison.Assoc.Defaults where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)--import qualified Control.Monad.Fail as Fail--import Data.Edison.Assoc-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)--singletonUsingInsert :: (Assoc m k) => k -> a -> m a-singletonUsingInsert k v = insert k v empty--fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a-fromSeqUsingInsertSeq kvs = insertSeq kvs empty--insertSeqUsingFoldr ::-    (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a-insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs--unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a-unionSeqUsingReduce ms = S.reducel union empty ms--deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a-deleteSeqUsingFoldr ks m = S.foldr delete m ks--memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool-memberUsingLookupM k m-  = case lookupM k m of-        Just _  -> True-        Nothing -> False--countUsingMember :: AssocX m k => k -> m a -> Int-countUsingMember k m = if member k m then 1 else 0--lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a-lookupAllUsingLookupM k m = case lookupM k m of-                              Just x -> S.singleton x-                              Nothing -> S.empty--lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a-lookupWithDefaultUsingLookupM d k m = case lookupM k m of-                                        Just x -> x-                                        Nothing -> d--partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a)-partitionUsingFilter f m = (filter f m, filter (not . f) m)--fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a-fold1UsingElements op m = L.foldr1 op (elements m)--elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a-elementsUsingFold = fold S.lcons S.empty--nullUsingElements :: (AssocX m k) => m a -> Bool-nullUsingElements m-  = case elements m of-        [] -> True-        _  -> False--insertWithUsingLookupM ::-    FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a-insertWithUsingLookupM f k x m =-    case lookupM k m of-      Nothing -> insert k x m-      Just y  -> insert k (f x y) m--fromSeqWithUsingInsertSeqWith ::-    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a-fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty--fromSeqWithKeyUsingInsertSeqWithKey ::-    (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a-fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty--insertWithKeyUsingInsertWith ::-    FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a-insertWithKeyUsingInsertWith f k = insertWith (f k) k--insertSeqWithUsingInsertWith ::-    (FiniteMapX m k,S.Sequence seq) =>-      (a -> a -> a) -> seq (k,a) -> m a -> m a-insertSeqWithUsingInsertWith f kvs m =-    S.foldr (uncurry (insertWith f)) m kvs--insertSeqWithKeyUsingInsertWithKey ::-    (FiniteMapX m k,S.Sequence seq) =>-      (k -> a -> a -> a) -> seq (k,a) -> m a -> m a-insertSeqWithKeyUsingInsertWithKey f kvs m =-    S.foldr (uncurry (insertWithKey f)) m kvs--unionSeqWithUsingReduce ::-    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a-unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms--unionSeqWithUsingFoldr ::-    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a-unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms--toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a)-toSeqUsingFoldWithKey = foldWithKey conspair S.empty-  where conspair k v kvs = S.lcons (k,v) kvs--keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k-keysUsingFoldWithKey = foldWithKey conskey S.empty-  where conskey k _ ks = S.lcons k ks--unionWithUsingInsertWith ::-    FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a-unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1--unionWithKeyUsingInsertWithKey ::-    FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a-unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1--unionSeqWithKeyUsingReduce ::-    (FiniteMap m k,S.Sequence seq) =>-      (k -> a -> a -> a) -> seq (m a) -> m a-unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms--unionSeqWithKeyUsingFoldr ::-    (FiniteMap m k,S.Sequence seq) =>-      (k -> a -> a -> a) -> seq (m a) -> m a-unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms--intersectionWithUsingLookupM ::-    FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c-intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1-  where ins k x m = case lookupM k m2 of-                      Nothing -> m-                      Just y  -> insert k (f x y) m--intersectionWithKeyUsingLookupM ::-    FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c-intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1-  where ins k x m = case lookupM k m2 of-                      Nothing -> m-                      Just y  -> insert k (f k x y) m--differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a-differenceUsingDelete m1 m2 = foldWithKey del m1 m2-  where del k _ m = delete k m--properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool-properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2--subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool-subsetUsingMember m1 m2 = foldWithKey mem True m1-  where mem k _ b = member k m2 && b--submapByUsingLookupM :: FiniteMap m k-                     => (a -> a -> Bool) -> m a -> m a -> Bool-submapByUsingLookupM  f m1 m2 = foldWithKey aux True m1-  where aux k x b =-          case lookupM k m2 of-             Nothing -> False-             Just y  -> f x y && b--properSubmapByUsingSubmapBy :: FiniteMapX m k-                            => (a -> a -> Bool) -> m a -> m a -> Bool-properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2--sameMapByUsingOrdLists :: OrdFiniteMap m k-                       => (a -> a -> Bool) -> m a -> m a -> Bool-sameMapByUsingOrdLists f m1 m2 =-   let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2-   in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2))---sameMapByUsingSubmapBy :: FiniteMapX m k-                       => (a -> a -> Bool) -> m a -> m a -> Bool-sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2---lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a)-lookupAndDeleteDefault k m =-  case lookupM k m of-     Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed")-     Just x  -> (x, delete k m)--lookupAndDeleteMDefault :: (Fail.MonadFail rm, AssocX m k) => k -> m a -> rm (a, m a)-lookupAndDeleteMDefault k m =-  case lookupM k m of-     Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed")-     Just x  -> return (x, delete k m)--lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a)-lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m)--adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a-adjustOrInsertUsingMember f z k m =-  if member k m-     then adjust f k m-     else insert k z m--adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a-adjustOrDeleteDefault f k m =-  case lookupAndDeleteM k m of-    Nothing -> m-    Just (element,m') ->-      case f element of-         Nothing -> m'-         Just x  -> insert k x m'--adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a-adjustOrDeleteAllDefault f k m =-  let (elems,m') = lookupAndDeleteAll k m-      adjSeq = S.map f elems-      ins Nothing  n = n-      ins (Just x) n = insert k x n-  in L.foldr ins m' adjSeq--minElemUsingMinView :: OrdAssocX m k => m a -> a-minElemUsingMinView fm =-  case minView fm of-     Nothing    -> error $ (instanceName fm)++".minElem: empty map"-     Just (x,_) -> x--deleteMinUsingMinView :: OrdAssocX m k => m a -> m a-deleteMinUsingMinView fm =-  case minView fm of-     Nothing    -> error $ (instanceName fm)++".deleteMin: empty map"-     Just (_,m) -> m--minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a)-minElemWithKeyUsingMinViewWithKey fm =-  case minViewWithKey fm of-     Nothing    -> error $ (instanceName fm)++".minElemWithKey: empty map"-     Just (x,_) -> x--maxElemUsingMaxView :: OrdAssocX m k => m a -> a-maxElemUsingMaxView fm =-  case maxView fm of-     Nothing    -> error $ (instanceName fm)++".maxElem: empty map"-     Just (x,_) -> x--deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a-deleteMaxUsingMaxView fm =-  case maxView fm of-     Nothing    -> error $ (instanceName fm)++".deleteMax: empty map"-     Just (_,m) -> m--maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a)-maxElemWithKeyUsingMaxViewWithKey fm =-  case maxViewWithKey fm of-     Nothing    -> error $ (instanceName fm)++".maxElemWithKey: empty map"-     Just (x,_) -> x--toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a)-toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty--showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS-showsPrecUsingToList i xs rest-   | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]-   | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]--readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a)-readsPrecUsingFromList _ xs =-   let result = maybeParens p xs-       p ys = tokenMatch ((instanceName x)++".fromSeq") ys-                >>= readsPrec 10-                >>= \(l,rest) -> return (fromList l,rest)--       -- play games with the typechecker so we don't have to use-       -- extensions for scoped type variables-       ~[(x,_)] = result--   in result--showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS-showsPrecUsingToOrdList i xs rest-   | i == 0    = concat [    instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest]-   | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)]--readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a)-readsPrecUsingUnsafeFromOrdSeq i xs =-   let result = maybeParens p xs-       p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys-                >>= readsPrec i-                >>= \(l,rest) -> return (unsafeFromOrdList l,rest)--       -- play games with the typechecker so we don't have to use-       -- extensions for scoped type variables-       ~[(x,_)] = result--   in result--compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering-compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)- where-  cmp [] [] = EQ-  cmp [] _  = LT-  cmp _  [] = GT-  cmp (v:vs) (z:zs) =-      case compare v z of-         EQ -> cmp vs zs-         c -> c+-- |
+--   Module      :  Data.Edison.Assoc.Defaults
+--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  internal (unstable)
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module provides default implementations of many of the associative
+--   collection operations.  These function are used to fill in collection
+--   implementations and are not intended to be used directly by end users.
+
+module Data.Edison.Assoc.Defaults where
+
+import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
+
+import qualified Control.Monad.Fail as Fail
+
+import Data.Edison.Assoc
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)
+
+singletonUsingInsert :: (Assoc m k) => k -> a -> m a
+singletonUsingInsert k v = insert k v empty
+
+fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a
+fromSeqUsingInsertSeq kvs = insertSeq kvs empty
+
+insertSeqUsingFoldr ::
+    (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a
+insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs
+
+unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a
+unionSeqUsingReduce ms = S.reducel union empty ms
+
+deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a
+deleteSeqUsingFoldr ks m = S.foldr delete m ks
+
+memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool
+memberUsingLookupM k m
+  = case lookupM k m of
+        Just _  -> True
+        Nothing -> False
+
+countUsingMember :: AssocX m k => k -> m a -> Int
+countUsingMember k m = if member k m then 1 else 0
+
+lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a
+lookupAllUsingLookupM k m = case lookupM k m of
+                              Just x -> S.singleton x
+                              Nothing -> S.empty
+
+lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a
+lookupWithDefaultUsingLookupM d k m = case lookupM k m of
+                                        Just x -> x
+                                        Nothing -> d
+
+partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a)
+partitionUsingFilter f m = (filter f m, filter (not . f) m)
+
+fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a
+fold1UsingElements op m = L.foldr1 op (elements m)
+
+elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a
+elementsUsingFold = fold S.lcons S.empty
+
+nullUsingElements :: (AssocX m k) => m a -> Bool
+nullUsingElements m
+  = case elements m of
+        [] -> True
+        _  -> False
+
+insertWithUsingLookupM ::
+    FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a
+insertWithUsingLookupM f k x m =
+    case lookupM k m of
+      Nothing -> insert k x m
+      Just y  -> insert k (f x y) m
+
+fromSeqWithUsingInsertSeqWith ::
+    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a
+fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty
+
+fromSeqWithKeyUsingInsertSeqWithKey ::
+    (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a
+fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty
+
+insertWithKeyUsingInsertWith ::
+    FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a
+insertWithKeyUsingInsertWith f k = insertWith (f k) k
+
+insertSeqWithUsingInsertWith ::
+    (FiniteMapX m k,S.Sequence seq) =>
+      (a -> a -> a) -> seq (k,a) -> m a -> m a
+insertSeqWithUsingInsertWith f kvs m =
+    S.foldr (uncurry (insertWith f)) m kvs
+
+insertSeqWithKeyUsingInsertWithKey ::
+    (FiniteMapX m k,S.Sequence seq) =>
+      (k -> a -> a -> a) -> seq (k,a) -> m a -> m a
+insertSeqWithKeyUsingInsertWithKey f kvs m =
+    S.foldr (uncurry (insertWithKey f)) m kvs
+
+unionSeqWithUsingReduce ::
+    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a
+unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms
+
+unionSeqWithUsingFoldr ::
+    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a
+unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms
+
+toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a)
+toSeqUsingFoldWithKey = foldWithKey conspair S.empty
+  where conspair k v kvs = S.lcons (k,v) kvs
+
+keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k
+keysUsingFoldWithKey = foldWithKey conskey S.empty
+  where conskey k _ ks = S.lcons k ks
+
+unionWithUsingInsertWith ::
+    FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a
+unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1
+
+unionWithKeyUsingInsertWithKey ::
+    FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a
+unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1
+
+unionSeqWithKeyUsingReduce ::
+    (FiniteMap m k,S.Sequence seq) =>
+      (k -> a -> a -> a) -> seq (m a) -> m a
+unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms
+
+unionSeqWithKeyUsingFoldr ::
+    (FiniteMap m k,S.Sequence seq) =>
+      (k -> a -> a -> a) -> seq (m a) -> m a
+unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms
+
+intersectionWithUsingLookupM ::
+    FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c
+intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1
+  where ins k x m = case lookupM k m2 of
+                      Nothing -> m
+                      Just y  -> insert k (f x y) m
+
+intersectionWithKeyUsingLookupM ::
+    FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c
+intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1
+  where ins k x m = case lookupM k m2 of
+                      Nothing -> m
+                      Just y  -> insert k (f k x y) m
+
+differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a
+differenceUsingDelete m1 m2 = foldWithKey del m1 m2
+  where del k _ m = delete k m
+
+properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool
+properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2
+
+subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool
+subsetUsingMember m1 m2 = foldWithKey mem True m1
+  where mem k _ b = member k m2 && b
+
+submapByUsingLookupM :: FiniteMap m k
+                     => (a -> a -> Bool) -> m a -> m a -> Bool
+submapByUsingLookupM  f m1 m2 = foldWithKey aux True m1
+  where aux k x b =
+          case lookupM k m2 of
+             Nothing -> False
+             Just y  -> f x y && b
+
+properSubmapByUsingSubmapBy :: FiniteMapX m k
+                            => (a -> a -> Bool) -> m a -> m a -> Bool
+properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2
+
+sameMapByUsingOrdLists :: OrdFiniteMap m k
+                       => (a -> a -> Bool) -> m a -> m a -> Bool
+sameMapByUsingOrdLists f m1 m2 =
+   let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2
+   in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2))
+
+
+sameMapByUsingSubmapBy :: FiniteMapX m k
+                       => (a -> a -> Bool) -> m a -> m a -> Bool
+sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2
+
+
+lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a)
+lookupAndDeleteDefault k m =
+  case lookupM k m of
+     Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed")
+     Just x  -> (x, delete k m)
+
+lookupAndDeleteMDefault :: (Fail.MonadFail rm, AssocX m k) => k -> m a -> rm (a, m a)
+lookupAndDeleteMDefault k m =
+  case lookupM k m of
+     Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed")
+     Just x  -> return (x, delete k m)
+
+lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a)
+lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m)
+
+adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a
+adjustOrInsertUsingMember f z k m =
+  if member k m
+     then adjust f k m
+     else insert k z m
+
+adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a
+adjustOrDeleteDefault f k m =
+  case lookupAndDeleteM k m of
+    Nothing -> m
+    Just (element,m') ->
+      case f element of
+         Nothing -> m'
+         Just x  -> insert k x m'
+
+adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a
+adjustOrDeleteAllDefault f k m =
+  let (elems,m') = lookupAndDeleteAll k m
+      adjSeq = S.map f elems
+      ins Nothing  n = n
+      ins (Just x) n = insert k x n
+  in L.foldr ins m' adjSeq
+
+minElemUsingMinView :: OrdAssocX m k => m a -> a
+minElemUsingMinView fm =
+  case minView fm of
+     Nothing    -> error $ (instanceName fm)++".minElem: empty map"
+     Just (x,_) -> x
+
+deleteMinUsingMinView :: OrdAssocX m k => m a -> m a
+deleteMinUsingMinView fm =
+  case minView fm of
+     Nothing    -> error $ (instanceName fm)++".deleteMin: empty map"
+     Just (_,m) -> m
+
+minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a)
+minElemWithKeyUsingMinViewWithKey fm =
+  case minViewWithKey fm of
+     Nothing    -> error $ (instanceName fm)++".minElemWithKey: empty map"
+     Just (x,_) -> x
+
+maxElemUsingMaxView :: OrdAssocX m k => m a -> a
+maxElemUsingMaxView fm =
+  case maxView fm of
+     Nothing    -> error $ (instanceName fm)++".maxElem: empty map"
+     Just (x,_) -> x
+
+deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a
+deleteMaxUsingMaxView fm =
+  case maxView fm of
+     Nothing    -> error $ (instanceName fm)++".deleteMax: empty map"
+     Just (_,m) -> m
+
+maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a)
+maxElemWithKeyUsingMaxViewWithKey fm =
+  case maxViewWithKey fm of
+     Nothing    -> error $ (instanceName fm)++".maxElemWithKey: empty map"
+     Just (x,_) -> x
+
+toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a)
+toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty
+
+showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS
+showsPrecUsingToList i xs rest
+   | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]
+   | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]
+
+readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a)
+readsPrecUsingFromList _ xs =
+   let result = maybeParens p xs
+       p ys = tokenMatch ((instanceName x)++".fromSeq") ys
+                >>= readsPrec 10
+                >>= \(l,rest) -> return (fromList l,rest)
+
+       -- play games with the typechecker so we don't have to use
+       -- extensions for scoped type variables
+       x = case result of
+        [(x',_)] -> x'
+        _ -> undefined
+
+   in result
+
+showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS
+showsPrecUsingToOrdList i xs rest
+   | i == 0    = concat [    instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest]
+   | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)]
+
+readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a)
+readsPrecUsingUnsafeFromOrdSeq i xs =
+   let result = maybeParens p xs
+       p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys
+                >>= readsPrec i
+                >>= \(l,rest) -> return (unsafeFromOrdList l,rest)
+
+       -- play games with the typechecker so we don't have to use
+       -- extensions for scoped type variables
+       x = case result of
+        [(x',_)] -> x'
+        _ -> undefined
+
+   in result
+
+compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering
+compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)
+ where
+  cmp [] [] = EQ
+  cmp [] _  = LT
+  cmp _  [] = GT
+  cmp (v:vs) (z:zs) =
+      case compare v z of
+         EQ -> cmp vs zs
+         c -> c

src/Data/Edison/Assoc/PatriciaLoMap.hs view

@@ -1,854 +1,854 @@--- |---   Module      :  Data.Edison.Assoc.PatriciaLoMap---   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Finite maps implemented as little-endian Patricia trees.------   /References:/------ * Chris Okasaki and Any Gill.  \"Fast Mergeable Integer Maps\".---   Workshop on ML, September 1998, pages 77-86.--module Data.Edison.Assoc.PatriciaLoMap (-    -- * Type of little-endian Patricia trees-    FM,--    -- * AssocX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,-    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith,-    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map,-    fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,--    -- * Assoc operations-    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,--    -- * FiniteMapX operations-    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,-    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,-    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,-    properSubmap,submap,sameMap,--    -- * FiniteMap operations-    unionWithKey,unionSeqWithKey,intersectionWithKey,--    -- * OrdAssocX operations-    minView, minElem, deleteMin, unsafeInsertMin,-    maxView, maxElem, deleteMax, unsafeInsertMax,-    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',-    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,-    partitionLT_GE, partitionLE_GT, partitionLT_GT,--    -- * OrdAssoc operations-    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,-    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',-    toOrdSeq,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)-import qualified Prelude-import qualified Control.Monad.Fail as Fail-import Data.Monoid-import Data.Semigroup as SG-import qualified Data.Edison.Assoc as A-import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Assoc.Defaults-import Data.Int-import Data.Bits-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)--moduleName :: String-moduleName = "Data.Edison.Assoc.PatriciaLoMap"--data FM a-  = E-  | L Int a-  | B Int Int !(FM a) !(FM a)---- Invariants:--- * No B node has an E child--- * first argument to B is a prefix--- * second argument to B is the "branching bit" and is---   always an exact power of two--- * all bits in the prefix >= the branching bit are zeros--- * valid prefix bits match all subnodes--structuralInvariant :: FM a -> Bool-structuralInvariant E = True-structuralInvariant (L _ _) = True-structuralInvariant x = inv 0 0 x--inv :: Int -> Int -> FM a -> Bool-inv _ _ E = False-inv pre msk (L k _) = k .&. msk == pre-inv pre msk (B p m t0 t1) =-    (p .&. msk == pre) &&-    (bitcount 0 m == 1) &&-    (p .&. (complement (m - 1)) == 0) &&-    inv p0 msk' t0 &&-    inv p1 msk' t1--  where p0 = p-        p1 = p .|. m-        msk' = (m `shiftL` 1) - 1--bitcount :: Int -> Int -> Int-bitcount a 0 = a-bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))---- auxiliary functions--makeB :: Int -> Int -> FM t -> FM t -> FM t-makeB _ _ E t = t-makeB _ _ t E = t-makeB p m t0 t1 = B p m t0 t1--lmakeB :: Int -> Int -> FM t -> FM t -> FM t-lmakeB _ _ E t = t-lmakeB p m t0 t1 = B p m t0 t1--rmakeB :: Int -> Int -> FM a -> FM a -> FM a-rmakeB _ _ t E = t-rmakeB p m t0 t1 = B p m t0 t1--lowestBit :: Word -> Word-lowestBit x = x .&. (-x)--branchingBit :: Int -> Int -> Int-branchingBit p0 p1 =-  fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1))--mask :: Int -> Int -> Int-mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Word)))--shorter :: Int -> Int -> Bool-shorter m n = fromIntegral m < (fromIntegral n :: Word)--zeroBit :: Int -> Int -> Bool-zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Word)--matchPrefix :: Int -> Int -> Int -> Bool-matchPrefix k p m = mask k m == p--join :: Int -> FM a -> Int -> FM a -> FM a-join p0 t0 p1 t1 =-  let m = branchingBit p0 p1-  in if zeroBit p0 m then B (mask p0 m) m t0 t1-                     else B (mask p0 m) m t1 t0--keepR :: forall t t1. t -> t1 -> t1-keepR _ y = y---- end auxiliary functions--empty :: FM a-empty = E--singleton :: Int -> a -> FM a-singleton k x = L k x--fromSeq :: S.Sequence seq => seq (Int,a) -> FM a-fromSeq = S.foldl (\t (k, x) -> insert k x t) E--insert :: Int -> a -> FM a -> FM a-insert k x E = L k x-insert k x t@(L j _) = if j == k then L k x else join k (L k x) j t-insert k x t@(B p m t0 t1) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insert k x t0) t1-                     else B p m t0 (insert k x t1)-    else join k (L k x) p t--union :: FM a -> FM a -> FM a-union s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then B p m (union s0 t) s1-                                 else B p m s0 (union s1 t)-                else join p s q t-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then B q n (union s t0) t1-                                 else B q n t0 (union s t1)-                else join p s q t-  | otherwise = if p == q then B p m (union s0 t0) (union s1 t1)-                else join p s q t-union s@(B p m s0 s1) (L k x) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insert k x s0) s1-                     else B p m s0 (insert k x s1)-    else join k (L k x) p s-union s@(B _ _ _ _) E = s-union (L k x) t = insert k x t-union E t = t--delete :: Int -> FM a -> FM a-delete _ E = E-delete k t@(L j _) = if k == j then E else t-delete k t@(B p m t0 t1) =-    if matchPrefix k p m then-      if zeroBit k m then lmakeB p m (delete k t0) t1-                     else rmakeB p m t0 (delete k t1)-    else t--null :: FM a -> Bool-null E = True-null _ = False--size :: FM a -> Int-size E = 0-size (L _ _) = 1-size (B _ _ t0 t1) = size t0 + size t1--member :: Int -> FM a -> Bool-member _ E = False-member k (L j _) = (j == k)-member k (B _ m t0 t1) = if zeroBit k m then member k t0 else member k t1--lookup :: Int -> FM a -> a-lookup k m = runFail_ (lookupM k m)--lookupM :: (Fail.MonadFail rm) => Int -> FM a -> rm a-lookupM _ E = fail "PatriciaLoMap.lookup: lookup failed"-lookupM k (L j x)-  | j == k    = return x-  | otherwise = fail "PatriciaLoMap.lookup: lookup failed"-lookupM k (B _ m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1--doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z-doLookupAndDelete onFail _ _ E = onFail-doLookupAndDelete onFail cont k (L j x)-     | j == k    = cont x E-     | otherwise = onFail-doLookupAndDelete onFail cont k (B p m t0 t1)-     | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0-     | otherwise   = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1--lookupAndDelete :: Int -> FM a -> (a, FM a)-lookupAndDelete        = doLookupAndDelete-                           (error "PatriciaLoMap.lookupAndDelete: lookup failed")-                           (,)--lookupAndDeleteM :: Fail.MonadFail m => Int -> FM a -> m (a, FM a)-lookupAndDeleteM       = doLookupAndDelete-                           (fail "PatriciaLoMap.lookupAndDelete: lookup failed")-                           (\x m -> return (x,m))--lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a)-lookupAndDeleteAll k m = doLookupAndDelete-                           (S.empty, m)-                           (\x m' -> (S.singleton x,m'))-                           k m---adjust :: (a -> a) -> Int -> FM a -> FM a-adjust _ _ E = E-adjust f k t@(L j x) = if k == j then L k (f x) else t-adjust f k t@(B p m t0 t1) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (adjust f k t0) t1-                     else B p m t0 (adjust f k t1)-    else t---- FIXME can we do better than this?-adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a-adjustOrInsert = adjustOrInsertUsingMember--adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a-adjustAllOrInsert = adjustOrInsertUsingMember--adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a-adjustOrDelete = adjustOrDeleteDefault--adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a-adjustOrDeleteAll = adjustOrDeleteDefault--map :: (a -> b) -> FM a -> FM b-map _ E = E-map f (L k x) = L k (f x)-map f (B p m t0 t1) = B p m (map f t0) (map f t1)--fold :: (a -> b -> b) -> b -> FM a -> b-fold _ c E = c-fold f c (L _ x) = f x c-fold f c (B _ _ t0 t1) = fold f (fold f c t1) t0--fold' :: (a -> b -> b) -> b -> FM a -> b-fold' _ c E = c-fold' f c (L _ x) = c `seq` f x c-fold' f c (B _ _ t0 t1) = c `seq` (fold f $! (fold f c t1)) t0--fold1 :: (a -> a -> a) -> FM a -> a-fold1 _ E = error "PatriciaLoMap.fold1: empty map"-fold1 _ (L _ x) = x-fold1 f (B _ _ t0 t1) = f (fold1 f t0) (fold1 f t1)--fold1' :: (a -> a -> a) -> FM a -> a-fold1' _ E = error "PatriciaLoMap.fold1: empty map"-fold1' _ (L _ x) = x-fold1' f (B _ _ t0 t1) = f (fold1' f t0) $! (fold1' f t1)--filter :: (a -> Bool) -> FM a -> FM a-filter _ E = E-filter g t@(L _ x) = if g x then t else E-filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1)--partition :: (a -> Bool) -> FM a -> (FM a, FM a)-partition _ E = (E, E)-partition g t@(L _ x) = if g x then (t, E) else (E, t)-partition g (B p m t0 t1) =-  let (t0',t0'') = partition g t0-      (t1',t1'') = partition g t1-  in (makeB p m t0' t1', makeB p m t0'' t1'')--fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a-fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E--insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a-insertWith _ k x E = L k x-insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t-insertWith f k x t@(B p m t0 t1) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insertWith f k x t0) t1-                     else B p m t0 (insertWith f k x t1)-    else join k (L k x) p t--unionl :: FM a -> FM a -> FM a-unionl s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then B p m (unionl s0 t) s1-                                 else B p m s0 (unionl s1 t)-                else join p s q t-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then B q n (unionl s t0) t1-                                 else B q n t0 (unionl s t1)-                else join p s q t-  | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1)-                else join p s q t-unionl s@(B p m s0 s1) (L k x) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insertWith keepR k x s0) s1-                     else B p m s0 (insertWith keepR k x s1)-    else join k (L k x) p s-unionl s@(B _ _ _ _) E = s-unionl (L k x) t = insert k x t-unionl E t = t--unionr :: FM a -> FM a -> FM a-unionr s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then B p m (unionr s0 t) s1-                                 else B p m s0 (unionr s1 t)-                else join p s q t-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then B q n (unionr s t0) t1-                                 else B q n t0 (unionr s t1)-                else join p s q t-  | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1)-                else join p s q t-unionr s@(B p m s0 s1) (L k x) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insert k x s0) s1-                     else B p m s0 (insert k x s1)-    else join k (L k x) p s-unionr s@(B _ _ _ _) E = s-unionr (L k x) t = insertWith keepR k x t-unionr E t = t--unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a-unionWith f s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then B p m (unionWith f s0 t) s1-                                 else B p m s0 (unionWith f s1 t)-                else join p s q t-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then B q n (unionWith f s t0) t1-                                 else B q n t0 (unionWith f s t1)-                else join p s q t-  | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1)-                else join p s q t-unionWith f s@(B p m s0 s1) (L k x) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insertWith (flip f) k x s0) s1-                     else B p m s0 (insertWith (flip f) k x s1)-    else join k (L k x) p s-unionWith _ s@(B _ _ _ _) E = s-unionWith f (L k x) t = insertWith f k x t-unionWith _ E t = t--intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c-intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then intersectionWith f s0 t-                                 else intersectionWith f s1 t-                else E-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then intersectionWith f s t0-                                 else intersectionWith f s t1-                else E-  | otherwise = if p /= q then E-                else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1)-intersectionWith f (B _ m s0 s1) (L k y) =-    case lookupM k (if zeroBit k m then s0 else s1) of-      Just x  -> L k (f x y)-      Nothing -> E-intersectionWith _ (B _ _ _ _) E = E-intersectionWith f (L k x) t =-    case lookupM k t of-      Just y  -> L k (f x y)-      Nothing -> E-intersectionWith _ E _ = E--difference :: FM a -> FM b -> FM a-difference s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then lmakeB p m (difference s0 t) s1-                                 else rmakeB p m s0 (difference s1 t)-                else s-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then difference s t0-                                 else difference s t1-                else s-  | otherwise = if p /= q then s-                else makeB p m (difference s0 t0) (difference s1 t1)-difference s@(B p m s0 s1) (L k _) =-    if matchPrefix k p m then-      if zeroBit k m then lmakeB p m (delete k s0) s1-                     else rmakeB p m s0 (delete k s1)-    else s-difference s@(B _ _ _ _) E = s-difference s@(L k _) t = if member k t then E else s-difference E _ = E--properSubset :: FM a -> FM b -> Bool-properSubset s t = case subset' s t of {LT -> True; _ -> False}--subset' :: FM t -> FM t1 -> Ordering-subset' s@(B p m s0 s1) (B q n t0 t1)-  | shorter m n = GT-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then subset' s t0 SG.<> LT-                                 else subset' s t1 SG.<> LT-                else GT-  | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of-                                  (GT,_)  -> GT-                                  (_,GT)  -> GT-                                  (EQ,EQ) -> EQ-                                  (_,_)   -> LT-                else GT-subset' (B _ _ _ _) _ = GT-subset' (L k _) (L j _) = if k == j then EQ else GT-subset' (L k _) t = if member k t then LT else GT-subset' E E = EQ-subset' E _ = LT--subset :: FM a -> FM b -> Bool-subset s@(B p m s0 s1) (B q n t0 t1)-  | shorter m n = False-  | shorter n m = matchPrefix p q n && (if zeroBit p n then subset s t0-                                                     else subset s t1)-  | otherwise = (p == q) && subset s0 t0 && subset s1 t1-subset (B _ _ _ _) _ = False-subset (L k _) t = member k t-subset E _ = True--properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-properSubmapBy = properSubmapByUsingSubmapBy--submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-submapBy = submapByUsingLookupM--sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-sameMapBy = sameMapByUsingSubmapBy--properSubmap :: (Eq a) => FM a -> FM a -> Bool-properSubmap = A.properSubmap--submap :: (Eq a) => FM a -> FM a -> Bool-submap = A.submap--sameMap :: (Eq a) => FM a -> FM a -> Bool-sameMap = A.sameMap--mapWithKey :: (Int -> a -> b) -> FM a -> FM b-mapWithKey _ E = E-mapWithKey f (L k x) = L k (f k x)-mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1)--foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b-foldWithKey _ c E = c-foldWithKey f c (L k x) = f k x c-foldWithKey f c (B _ _ t0 t1) = foldWithKey f (foldWithKey f c t1) t0--foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b-foldWithKey' _ c E = c-foldWithKey' f c (L k x) = c `seq` f k x c-foldWithKey' f c (B _ _ t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0---filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a-filterWithKey _ E = E-filterWithKey g t@(L k x) = if g k x then t else E-filterWithKey g (B p m t0 t1) =-  makeB p m (filterWithKey g t0) (filterWithKey g t1)--partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a)-partitionWithKey _ E = (E, E)-partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t)-partitionWithKey g (B p m t0 t1) =-  let (t0',t0'') = partitionWithKey g t0-      (t1',t1'') = partitionWithKey g t1-  in (makeB p m t0' t1', makeB p m t0'' t1'')--unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a-unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then B p m (unionWithKey f s0 t) s1-                                 else B p m s0 (unionWithKey f s1 t)-                else join p s q t-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then B q n (unionWithKey f s t0) t1-                                 else B q n t0 (unionWithKey f s t1)-                else join p s q t-  | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1)-                else join p s q t-unionWithKey f s@(B p m s0 s1) (L k x) =-    if matchPrefix k p m then-      if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1-                     else B p m s0 (insertWith (flip (f k)) k x s1)-    else join k (L k x) p s-unionWithKey _ s@(B _ _ _ _) E = s-unionWithKey f (L k x) t = insertWith (f k) k x t-unionWithKey _ E t = t--intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c-intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)-  | shorter m n = if matchPrefix q p m then-                  if zeroBit q m then intersectionWithKey f s0 t-                                 else intersectionWithKey f s1 t-                else E-  | shorter n m = if matchPrefix p q n then-                  if zeroBit p n then intersectionWithKey f s t0-                                 else intersectionWithKey f s t1-                else E-  | otherwise = if p /= q then E-                else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1)-intersectionWithKey f (B _ m s0 s1) (L k y) =-    case lookupM k (if zeroBit k m then s0 else s1) of-      Just x  -> L k (f k x y)-      Nothing -> E-intersectionWithKey _ (B _ _ _ _) E = E-intersectionWithKey f (L k x) t =-    case lookupM k t of-      Just y  -> L k (f k x y)-      Nothing -> E-intersectionWithKey _ E _ = E---- Datastructure definition is strict in all submaps,--- no forcing required-strict :: t -> t-strict n = n--strictWith :: (t -> a) -> FM t -> FM t-strictWith _ n@E = n-strictWith f n@(L _ x) = f x `seq` n-strictWith f n@(B _ _ m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n---ordListFM :: FM a -> [(Int,a)]-ordListFM E = []-ordListFM (L k x) = [(k,x)]-ordListFM (B _ _ t0 t1) = merge (ordListFM t0) (ordListFM t1)-  where merge [] ys = ys-        merge xs [] = xs-        merge (x@(k1,_):xs) (y@(k2,_):ys) =-           case compare k1 k2 of-              LT -> x : merge xs (y:ys)-              GT -> y : merge (x:xs) ys-              EQ -> error "PatriciaLoMap: bug in ordListFM"--ordListFM_rev :: FM a -> [(Int,a)]-ordListFM_rev E = []-ordListFM_rev (L k x) = [(k,x)]-ordListFM_rev (B _ _ t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1)-  where merge [] ys = ys-        merge xs [] = xs-        merge (x@(k1,_):xs) (y@(k2,_):ys) =-         case compare k1 k2 of-            LT -> y : merge (x:xs) ys-            GT -> x : merge xs (y:ys)-            EQ -> error "PatriciaLoMap: bug in ordListFM_rev"--minView :: Fail.MonadFail m => FM a -> m (a, FM a)-minView fm =-   case ordListFM fm of-     [] -> fail $ moduleName++".minView: empty map"-     ((k,x):_) -> return (x,delete k fm)--minViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a)-minViewWithKey fm =-   case ordListFM fm of-     [] -> fail $ moduleName++".minViewWithKey: empty map"-     ((k,x):_) -> return ((k,x),delete k fm)--maxView :: Fail.MonadFail m => FM a -> m (a, FM a)-maxView fm =-  case ordListFM_rev fm of-     [] -> fail $ moduleName++".maxView: empty map"-     ((k,x):_) -> return (x,delete k fm)--maxViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a)-maxViewWithKey fm =-   case ordListFM_rev fm of-     [] -> fail $ moduleName++".maxViewWithKey: empty map"-     ((k,x):_) -> return ((k,x),delete k fm)--minElem :: FM a -> a-minElem = minElemUsingMinView--minElemWithKey :: FM a -> (Int,a)-minElemWithKey = minElemWithKeyUsingMinViewWithKey--deleteMin :: FM a -> FM a-deleteMin = deleteMinUsingMinView--unsafeInsertMin :: Int -> a -> FM a -> FM a-unsafeInsertMin = insert--maxElem :: FM a -> a-maxElem = maxElemUsingMaxView--deleteMax :: FM a -> FM a-deleteMax = deleteMaxUsingMaxView--maxElemWithKey :: FM a -> (Int,a)-maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey--unsafeInsertMax :: Int -> a -> FM a -> FM a-unsafeInsertMax = insert--foldr :: (a -> b -> b) -> b -> FM a -> b-foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm--foldr' :: (a -> b -> b) -> b -> FM a -> b-foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm--foldr1 :: (a -> a -> a) -> FM a -> a-foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm--foldr1' :: (a -> a -> a) -> FM a -> a-foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm--foldl :: (b -> a -> b) -> b -> FM a -> b-foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm--foldl' :: (b -> a -> b) -> b -> FM a -> b-foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm--foldl1 :: (a -> a -> a) -> FM a -> a-foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm--foldl1' :: (a -> a -> a) -> FM a -> a-foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm--foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b-foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm--foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b-foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm--foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b-foldlWithKey f z fm = L.foldr (\(k,x) a -> f a k x) z . ordListFM_rev $ fm--foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b-foldlWithKey' f z fm = L.foldl' (\a (k,x) -> f a k x) z . ordListFM $ fm---unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a-unsafeFromOrdSeq = fromSeq--unsafeAppend :: FM a -> FM a -> FM a-unsafeAppend = union--filterLT :: Int -> FM a -> FM a-filterLT k = filterWithKey (\k' _ -> k' < k)--filterLE :: Int -> FM a -> FM a-filterLE k = filterWithKey (\k' _ -> k' <= k)--filterGT :: Int -> FM a -> FM a-filterGT k = filterWithKey (\k' _ -> k' > k)--filterGE :: Int -> FM a -> FM a-filterGE k = filterWithKey (\k' _ -> k' >= k)--partitionLT_GE :: Int -> FM a -> (FM a, FM a)-partitionLT_GE k fm = (filterLT k fm,filterGE k fm)--partitionLE_GT :: Int -> FM a -> (FM a,FM a)-partitionLE_GT k fm = (filterLE k fm,filterGT k fm)--partitionLT_GT :: Int -> FM a -> (FM a,FM a)-partitionLT_GT k fm = (filterLT k fm,filterGT k fm)--toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a)-toOrdSeq = L.foldr S.lcons S.empty . ordListFM---- defaults--insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a-insertSeq = insertSeqUsingFoldr--unionSeq :: S.Sequence seq => seq (FM a) -> FM a-unionSeq = unionSeqUsingReduce--deleteAll :: Int -> FM a -> FM a-deleteAll = delete--deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a-deleteSeq = deleteSeqUsingFoldr--count :: Int -> FM a -> Int-count = countUsingMember--lookupAll :: S.Sequence seq => Int -> FM a -> seq a-lookupAll = lookupAllUsingLookupM--lookupWithDefault :: a -> Int -> FM a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--elements :: S.Sequence seq => FM a -> seq a-elements = elementsUsingFold--fromSeqWithKey ::-    S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a-fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey--insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a-insertWithKey = insertWithKeyUsingInsertWith--insertSeqWith ::-    S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a-insertSeqWith = insertSeqWithUsingInsertWith--insertSeqWithKey ::-    S.Sequence seq =>-      (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a-insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey--adjustAll :: (a -> a) -> Int -> FM a -> FM a-adjustAll = adjust--unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a-unionSeqWith = unionSeqWithUsingReduce--toSeq :: S.Sequence seq => FM a -> seq (Int,a)-toSeq = toSeqUsingFoldWithKey--keys :: S.Sequence seq => FM a -> seq Int-keys = keysUsingFoldWithKey--unionSeqWithKey ::-    S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a-unionSeqWithKey = unionSeqWithKeyUsingReduce---- instance declarations--instance A.AssocX FM Int where-  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; union = union; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;-   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;-   lookupAndDeleteAll = lookupAndDeleteAll;-   lookupWithDefault = lookupWithDefault; adjust = adjust;-   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;-   adjustAllOrInsert = adjustAllOrInsert;-   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; elements = elements;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance A.Assoc FM Int where-  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;-   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';-   filterWithKey = filterWithKey;-   partitionWithKey = partitionWithKey}--instance A.FiniteMapX FM Int where-  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;-   insertWith = insertWith; insertWithKey = insertWithKey;-   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;-   unionl = unionl; unionr = unionr; unionWith = unionWith;-   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;-   difference = difference; properSubset = properSubset; subset = subset;-   properSubmapBy = properSubmapBy; submapBy = submapBy;-   sameMapBy = sameMapBy}--instance A.FiniteMap FM Int where-  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;-   intersectionWithKey = intersectionWithKey}--instance A.OrdAssocX FM Int where-  {minView = minView; minElem = minElem; deleteMin = deleteMin;-   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;-   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance A.OrdAssoc FM Int where-  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;-   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;-   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';-   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';-   toOrdSeq = toOrdSeq}--instance A.OrdFiniteMapX FM Int-instance A.OrdFiniteMap FM Int--instance Functor FM where-  fmap = map--instance (Show a) => Show (FM a) where-  showsPrec = showsPrecUsingToList--instance (Read a) => Read (FM a) where-  readsPrec = readsPrecUsingFromList--instance (Eq a) => Eq (FM a) where-  (==) = sameMap--instance (Ord a) => Ord (FM a) where-  compare = compareUsingToOrdList--instance (Arbitrary a) => Arbitrary (FM a) where-   arbitrary = do (xs::[(Int,a)]) <- arbitrary-                  return (Prelude.foldr (uncurry insert) empty xs)--instance (CoArbitrary a) => CoArbitrary (FM a) where-   coarbitrary E = variant 0-   coarbitrary (L i a) = variant 1 . coarbitrary i . coarbitrary a-   coarbitrary (B i j m n) = variant 2 . coarbitrary i . coarbitrary j-                           . coarbitrary m . coarbitrary n---instance Semigroup (FM a) where-   (<>) = union-instance Monoid (FM a) where-   mempty  = empty-   mappend = (SG.<>)-   mconcat = unionSeq+-- |
+--   Module      :  Data.Edison.Assoc.PatriciaLoMap
+--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Finite maps implemented as little-endian Patricia trees.
+--
+--   /References:/
+--
+-- * Chris Okasaki and Any Gill.  \"Fast Mergeable Integer Maps\".
+--   Workshop on ML, September 1998, pages 77-86.
+
+module Data.Edison.Assoc.PatriciaLoMap (
+    -- * Type of little-endian Patricia trees
+    FM,
+
+    -- * AssocX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,
+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith,
+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map,
+    fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,
+
+    -- * Assoc operations
+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,
+
+    -- * FiniteMapX operations
+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,
+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,
+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,
+    properSubmap,submap,sameMap,
+
+    -- * FiniteMap operations
+    unionWithKey,unionSeqWithKey,intersectionWithKey,
+
+    -- * OrdAssocX operations
+    minView, minElem, deleteMin, unsafeInsertMin,
+    maxView, maxElem, deleteMax, unsafeInsertMax,
+    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',
+    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,
+    partitionLT_GE, partitionLE_GT, partitionLT_GT,
+
+    -- * OrdAssoc operations
+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,
+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',
+    toOrdSeq,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
+import qualified Prelude
+import qualified Control.Monad.Fail as Fail
+import Data.Monoid
+import Data.Semigroup as SG
+import qualified Data.Edison.Assoc as A
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Assoc.Defaults
+import Data.Int
+import Data.Bits
+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)
+
+moduleName :: String
+moduleName = "Data.Edison.Assoc.PatriciaLoMap"
+
+data FM a
+  = E
+  | L Int a
+  | B Int Int !(FM a) !(FM a)
+
+-- Invariants:
+-- * No B node has an E child
+-- * first argument to B is a prefix
+-- * second argument to B is the "branching bit" and is
+--   always an exact power of two
+-- * all bits in the prefix >= the branching bit are zeros
+-- * valid prefix bits match all subnodes
+
+structuralInvariant :: FM a -> Bool
+structuralInvariant E = True
+structuralInvariant (L _ _) = True
+structuralInvariant x = inv 0 0 x
+
+inv :: Int -> Int -> FM a -> Bool
+inv _ _ E = False
+inv pre msk (L k _) = k .&. msk == pre
+inv pre msk (B p m t0 t1) =
+    (p .&. msk == pre) &&
+    (bitcount 0 m == 1) &&
+    (p .&. (complement (m - 1)) == 0) &&
+    inv p0 msk' t0 &&
+    inv p1 msk' t1
+
+  where p0 = p
+        p1 = p .|. m
+        msk' = (m `shiftL` 1) - 1
+
+bitcount :: Int -> Int -> Int
+bitcount a 0 = a
+bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))
+
+-- auxiliary functions
+
+makeB :: Int -> Int -> FM t -> FM t -> FM t
+makeB _ _ E t = t
+makeB _ _ t E = t
+makeB p m t0 t1 = B p m t0 t1
+
+lmakeB :: Int -> Int -> FM t -> FM t -> FM t
+lmakeB _ _ E t = t
+lmakeB p m t0 t1 = B p m t0 t1
+
+rmakeB :: Int -> Int -> FM a -> FM a -> FM a
+rmakeB _ _ t E = t
+rmakeB p m t0 t1 = B p m t0 t1
+
+lowestBit :: Word -> Word
+lowestBit x = x .&. (-x)
+
+branchingBit :: Int -> Int -> Int
+branchingBit p0 p1 =
+  fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1))
+
+mask :: Int -> Int -> Int
+mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Word)))
+
+shorter :: Int -> Int -> Bool
+shorter m n = fromIntegral m < (fromIntegral n :: Word)
+
+zeroBit :: Int -> Int -> Bool
+zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Word)
+
+matchPrefix :: Int -> Int -> Int -> Bool
+matchPrefix k p m = mask k m == p
+
+join :: Int -> FM a -> Int -> FM a -> FM a
+join p0 t0 p1 t1 =
+  let m = branchingBit p0 p1
+  in if zeroBit p0 m then B (mask p0 m) m t0 t1
+                     else B (mask p0 m) m t1 t0
+
+keepR :: forall t t1. t -> t1 -> t1
+keepR _ y = y
+
+-- end auxiliary functions
+
+empty :: FM a
+empty = E
+
+singleton :: Int -> a -> FM a
+singleton k x = L k x
+
+fromSeq :: S.Sequence seq => seq (Int,a) -> FM a
+fromSeq = S.foldl (\t (k, x) -> insert k x t) E
+
+insert :: Int -> a -> FM a -> FM a
+insert k x E = L k x
+insert k x t@(L j _) = if j == k then L k x else join k (L k x) j t
+insert k x t@(B p m t0 t1) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insert k x t0) t1
+                     else B p m t0 (insert k x t1)
+    else join k (L k x) p t
+
+union :: FM a -> FM a -> FM a
+union s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then B p m (union s0 t) s1
+                                 else B p m s0 (union s1 t)
+                else join p s q t
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then B q n (union s t0) t1
+                                 else B q n t0 (union s t1)
+                else join p s q t
+  | otherwise = if p == q then B p m (union s0 t0) (union s1 t1)
+                else join p s q t
+union s@(B p m s0 s1) (L k x) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insert k x s0) s1
+                     else B p m s0 (insert k x s1)
+    else join k (L k x) p s
+union s@(B _ _ _ _) E = s
+union (L k x) t = insert k x t
+union E t = t
+
+delete :: Int -> FM a -> FM a
+delete _ E = E
+delete k t@(L j _) = if k == j then E else t
+delete k t@(B p m t0 t1) =
+    if matchPrefix k p m then
+      if zeroBit k m then lmakeB p m (delete k t0) t1
+                     else rmakeB p m t0 (delete k t1)
+    else t
+
+null :: FM a -> Bool
+null E = True
+null _ = False
+
+size :: FM a -> Int
+size E = 0
+size (L _ _) = 1
+size (B _ _ t0 t1) = size t0 + size t1
+
+member :: Int -> FM a -> Bool
+member _ E = False
+member k (L j _) = (j == k)
+member k (B _ m t0 t1) = if zeroBit k m then member k t0 else member k t1
+
+lookup :: Int -> FM a -> a
+lookup k m = runFail_ (lookupM k m)
+
+lookupM :: (Fail.MonadFail rm) => Int -> FM a -> rm a
+lookupM _ E = fail "PatriciaLoMap.lookup: lookup failed"
+lookupM k (L j x)
+  | j == k    = return x
+  | otherwise = fail "PatriciaLoMap.lookup: lookup failed"
+lookupM k (B _ m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1
+
+doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z
+doLookupAndDelete onFail _ _ E = onFail
+doLookupAndDelete onFail cont k (L j x)
+     | j == k    = cont x E
+     | otherwise = onFail
+doLookupAndDelete onFail cont k (B p m t0 t1)
+     | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0
+     | otherwise   = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1
+
+lookupAndDelete :: Int -> FM a -> (a, FM a)
+lookupAndDelete        = doLookupAndDelete
+                           (error "PatriciaLoMap.lookupAndDelete: lookup failed")
+                           (,)
+
+lookupAndDeleteM :: Fail.MonadFail m => Int -> FM a -> m (a, FM a)
+lookupAndDeleteM       = doLookupAndDelete
+                           (fail "PatriciaLoMap.lookupAndDelete: lookup failed")
+                           (\x m -> return (x,m))
+
+lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a)
+lookupAndDeleteAll k m = doLookupAndDelete
+                           (S.empty, m)
+                           (\x m' -> (S.singleton x,m'))
+                           k m
+
+
+adjust :: (a -> a) -> Int -> FM a -> FM a
+adjust _ _ E = E
+adjust f k t@(L j x) = if k == j then L k (f x) else t
+adjust f k t@(B p m t0 t1) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (adjust f k t0) t1
+                     else B p m t0 (adjust f k t1)
+    else t
+
+-- FIXME can we do better than this?
+adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a
+adjustOrInsert = adjustOrInsertUsingMember
+
+adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a
+adjustAllOrInsert = adjustOrInsertUsingMember
+
+adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a
+adjustOrDelete = adjustOrDeleteDefault
+
+adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a
+adjustOrDeleteAll = adjustOrDeleteDefault
+
+map :: (a -> b) -> FM a -> FM b
+map _ E = E
+map f (L k x) = L k (f x)
+map f (B p m t0 t1) = B p m (map f t0) (map f t1)
+
+fold :: (a -> b -> b) -> b -> FM a -> b
+fold _ c E = c
+fold f c (L _ x) = f x c
+fold f c (B _ _ t0 t1) = fold f (fold f c t1) t0
+
+fold' :: (a -> b -> b) -> b -> FM a -> b
+fold' _ c E = c
+fold' f c (L _ x) = c `seq` f x c
+fold' f c (B _ _ t0 t1) = c `seq` (fold f $! (fold f c t1)) t0
+
+fold1 :: (a -> a -> a) -> FM a -> a
+fold1 _ E = error "PatriciaLoMap.fold1: empty map"
+fold1 _ (L _ x) = x
+fold1 f (B _ _ t0 t1) = f (fold1 f t0) (fold1 f t1)
+
+fold1' :: (a -> a -> a) -> FM a -> a
+fold1' _ E = error "PatriciaLoMap.fold1: empty map"
+fold1' _ (L _ x) = x
+fold1' f (B _ _ t0 t1) = f (fold1' f t0) $! (fold1' f t1)
+
+filter :: (a -> Bool) -> FM a -> FM a
+filter _ E = E
+filter g t@(L _ x) = if g x then t else E
+filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1)
+
+partition :: (a -> Bool) -> FM a -> (FM a, FM a)
+partition _ E = (E, E)
+partition g t@(L _ x) = if g x then (t, E) else (E, t)
+partition g (B p m t0 t1) =
+  let (t0',t0'') = partition g t0
+      (t1',t1'') = partition g t1
+  in (makeB p m t0' t1', makeB p m t0'' t1'')
+
+fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a
+fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E
+
+insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a
+insertWith _ k x E = L k x
+insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t
+insertWith f k x t@(B p m t0 t1) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insertWith f k x t0) t1
+                     else B p m t0 (insertWith f k x t1)
+    else join k (L k x) p t
+
+unionl :: FM a -> FM a -> FM a
+unionl s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then B p m (unionl s0 t) s1
+                                 else B p m s0 (unionl s1 t)
+                else join p s q t
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then B q n (unionl s t0) t1
+                                 else B q n t0 (unionl s t1)
+                else join p s q t
+  | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1)
+                else join p s q t
+unionl s@(B p m s0 s1) (L k x) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insertWith keepR k x s0) s1
+                     else B p m s0 (insertWith keepR k x s1)
+    else join k (L k x) p s
+unionl s@(B _ _ _ _) E = s
+unionl (L k x) t = insert k x t
+unionl E t = t
+
+unionr :: FM a -> FM a -> FM a
+unionr s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then B p m (unionr s0 t) s1
+                                 else B p m s0 (unionr s1 t)
+                else join p s q t
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then B q n (unionr s t0) t1
+                                 else B q n t0 (unionr s t1)
+                else join p s q t
+  | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1)
+                else join p s q t
+unionr s@(B p m s0 s1) (L k x) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insert k x s0) s1
+                     else B p m s0 (insert k x s1)
+    else join k (L k x) p s
+unionr s@(B _ _ _ _) E = s
+unionr (L k x) t = insertWith keepR k x t
+unionr E t = t
+
+unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a
+unionWith f s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then B p m (unionWith f s0 t) s1
+                                 else B p m s0 (unionWith f s1 t)
+                else join p s q t
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then B q n (unionWith f s t0) t1
+                                 else B q n t0 (unionWith f s t1)
+                else join p s q t
+  | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1)
+                else join p s q t
+unionWith f s@(B p m s0 s1) (L k x) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insertWith (flip f) k x s0) s1
+                     else B p m s0 (insertWith (flip f) k x s1)
+    else join k (L k x) p s
+unionWith _ s@(B _ _ _ _) E = s
+unionWith f (L k x) t = insertWith f k x t
+unionWith _ E t = t
+
+intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c
+intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then intersectionWith f s0 t
+                                 else intersectionWith f s1 t
+                else E
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then intersectionWith f s t0
+                                 else intersectionWith f s t1
+                else E
+  | otherwise = if p /= q then E
+                else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1)
+intersectionWith f (B _ m s0 s1) (L k y) =
+    case lookupM k (if zeroBit k m then s0 else s1) of
+      Just x  -> L k (f x y)
+      Nothing -> E
+intersectionWith _ (B _ _ _ _) E = E
+intersectionWith f (L k x) t =
+    case lookupM k t of
+      Just y  -> L k (f x y)
+      Nothing -> E
+intersectionWith _ E _ = E
+
+difference :: FM a -> FM b -> FM a
+difference s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then lmakeB p m (difference s0 t) s1
+                                 else rmakeB p m s0 (difference s1 t)
+                else s
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then difference s t0
+                                 else difference s t1
+                else s
+  | otherwise = if p /= q then s
+                else makeB p m (difference s0 t0) (difference s1 t1)
+difference s@(B p m s0 s1) (L k _) =
+    if matchPrefix k p m then
+      if zeroBit k m then lmakeB p m (delete k s0) s1
+                     else rmakeB p m s0 (delete k s1)
+    else s
+difference s@(B _ _ _ _) E = s
+difference s@(L k _) t = if member k t then E else s
+difference E _ = E
+
+properSubset :: FM a -> FM b -> Bool
+properSubset s t = case subset' s t of {LT -> True; _ -> False}
+
+subset' :: FM t -> FM t1 -> Ordering
+subset' s@(B p m s0 s1) (B q n t0 t1)
+  | shorter m n = GT
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then subset' s t0 SG.<> LT
+                                 else subset' s t1 SG.<> LT
+                else GT
+  | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of
+                                  (GT,_)  -> GT
+                                  (_,GT)  -> GT
+                                  (EQ,EQ) -> EQ
+                                  (_,_)   -> LT
+                else GT
+subset' (B _ _ _ _) _ = GT
+subset' (L k _) (L j _) = if k == j then EQ else GT
+subset' (L k _) t = if member k t then LT else GT
+subset' E E = EQ
+subset' E _ = LT
+
+subset :: FM a -> FM b -> Bool
+subset s@(B p m s0 s1) (B q n t0 t1)
+  | shorter m n = False
+  | shorter n m = matchPrefix p q n && (if zeroBit p n then subset s t0
+                                                     else subset s t1)
+  | otherwise = (p == q) && subset s0 t0 && subset s1 t1
+subset (B _ _ _ _) _ = False
+subset (L k _) t = member k t
+subset E _ = True
+
+properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool
+properSubmapBy = properSubmapByUsingSubmapBy
+
+submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool
+submapBy = submapByUsingLookupM
+
+sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool
+sameMapBy = sameMapByUsingSubmapBy
+
+properSubmap :: (Eq a) => FM a -> FM a -> Bool
+properSubmap = A.properSubmap
+
+submap :: (Eq a) => FM a -> FM a -> Bool
+submap = A.submap
+
+sameMap :: (Eq a) => FM a -> FM a -> Bool
+sameMap = A.sameMap
+
+mapWithKey :: (Int -> a -> b) -> FM a -> FM b
+mapWithKey _ E = E
+mapWithKey f (L k x) = L k (f k x)
+mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1)
+
+foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b
+foldWithKey _ c E = c
+foldWithKey f c (L k x) = f k x c
+foldWithKey f c (B _ _ t0 t1) = foldWithKey f (foldWithKey f c t1) t0
+
+foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b
+foldWithKey' _ c E = c
+foldWithKey' f c (L k x) = c `seq` f k x c
+foldWithKey' f c (B _ _ t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0
+
+
+filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a
+filterWithKey _ E = E
+filterWithKey g t@(L k x) = if g k x then t else E
+filterWithKey g (B p m t0 t1) =
+  makeB p m (filterWithKey g t0) (filterWithKey g t1)
+
+partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a)
+partitionWithKey _ E = (E, E)
+partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t)
+partitionWithKey g (B p m t0 t1) =
+  let (t0',t0'') = partitionWithKey g t0
+      (t1',t1'') = partitionWithKey g t1
+  in (makeB p m t0' t1', makeB p m t0'' t1'')
+
+unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a
+unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then B p m (unionWithKey f s0 t) s1
+                                 else B p m s0 (unionWithKey f s1 t)
+                else join p s q t
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then B q n (unionWithKey f s t0) t1
+                                 else B q n t0 (unionWithKey f s t1)
+                else join p s q t
+  | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1)
+                else join p s q t
+unionWithKey f s@(B p m s0 s1) (L k x) =
+    if matchPrefix k p m then
+      if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1
+                     else B p m s0 (insertWith (flip (f k)) k x s1)
+    else join k (L k x) p s
+unionWithKey _ s@(B _ _ _ _) E = s
+unionWithKey f (L k x) t = insertWith (f k) k x t
+unionWithKey _ E t = t
+
+intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c
+intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)
+  | shorter m n = if matchPrefix q p m then
+                  if zeroBit q m then intersectionWithKey f s0 t
+                                 else intersectionWithKey f s1 t
+                else E
+  | shorter n m = if matchPrefix p q n then
+                  if zeroBit p n then intersectionWithKey f s t0
+                                 else intersectionWithKey f s t1
+                else E
+  | otherwise = if p /= q then E
+                else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1)
+intersectionWithKey f (B _ m s0 s1) (L k y) =
+    case lookupM k (if zeroBit k m then s0 else s1) of
+      Just x  -> L k (f k x y)
+      Nothing -> E
+intersectionWithKey _ (B _ _ _ _) E = E
+intersectionWithKey f (L k x) t =
+    case lookupM k t of
+      Just y  -> L k (f k x y)
+      Nothing -> E
+intersectionWithKey _ E _ = E
+
+-- Datastructure definition is strict in all submaps,
+-- no forcing required
+strict :: t -> t
+strict n = n
+
+strictWith :: (t -> a) -> FM t -> FM t
+strictWith _ n@E = n
+strictWith f n@(L _ x) = f x `seq` n
+strictWith f n@(B _ _ m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n
+
+
+ordListFM :: FM a -> [(Int,a)]
+ordListFM E = []
+ordListFM (L k x) = [(k,x)]
+ordListFM (B _ _ t0 t1) = merge (ordListFM t0) (ordListFM t1)
+  where merge [] ys = ys
+        merge xs [] = xs
+        merge (x@(k1,_):xs) (y@(k2,_):ys) =
+           case compare k1 k2 of
+              LT -> x : merge xs (y:ys)
+              GT -> y : merge (x:xs) ys
+              EQ -> error "PatriciaLoMap: bug in ordListFM"
+
+ordListFM_rev :: FM a -> [(Int,a)]
+ordListFM_rev E = []
+ordListFM_rev (L k x) = [(k,x)]
+ordListFM_rev (B _ _ t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1)
+  where merge [] ys = ys
+        merge xs [] = xs
+        merge (x@(k1,_):xs) (y@(k2,_):ys) =
+         case compare k1 k2 of
+            LT -> y : merge (x:xs) ys
+            GT -> x : merge xs (y:ys)
+            EQ -> error "PatriciaLoMap: bug in ordListFM_rev"
+
+minView :: Fail.MonadFail m => FM a -> m (a, FM a)
+minView fm =
+   case ordListFM fm of
+     [] -> fail $ moduleName++".minView: empty map"
+     ((k,x):_) -> return (x,delete k fm)
+
+minViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a)
+minViewWithKey fm =
+   case ordListFM fm of
+     [] -> fail $ moduleName++".minViewWithKey: empty map"
+     ((k,x):_) -> return ((k,x),delete k fm)
+
+maxView :: Fail.MonadFail m => FM a -> m (a, FM a)
+maxView fm =
+  case ordListFM_rev fm of
+     [] -> fail $ moduleName++".maxView: empty map"
+     ((k,x):_) -> return (x,delete k fm)
+
+maxViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a)
+maxViewWithKey fm =
+   case ordListFM_rev fm of
+     [] -> fail $ moduleName++".maxViewWithKey: empty map"
+     ((k,x):_) -> return ((k,x),delete k fm)
+
+minElem :: FM a -> a
+minElem = minElemUsingMinView
+
+minElemWithKey :: FM a -> (Int,a)
+minElemWithKey = minElemWithKeyUsingMinViewWithKey
+
+deleteMin :: FM a -> FM a
+deleteMin = deleteMinUsingMinView
+
+unsafeInsertMin :: Int -> a -> FM a -> FM a
+unsafeInsertMin = insert
+
+maxElem :: FM a -> a
+maxElem = maxElemUsingMaxView
+
+deleteMax :: FM a -> FM a
+deleteMax = deleteMaxUsingMaxView
+
+maxElemWithKey :: FM a -> (Int,a)
+maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey
+
+unsafeInsertMax :: Int -> a -> FM a -> FM a
+unsafeInsertMax = insert
+
+foldr :: (a -> b -> b) -> b -> FM a -> b
+foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm
+
+foldr' :: (a -> b -> b) -> b -> FM a -> b
+foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm
+
+foldr1 :: (a -> a -> a) -> FM a -> a
+foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm
+
+foldr1' :: (a -> a -> a) -> FM a -> a
+foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm
+
+foldl :: (b -> a -> b) -> b -> FM a -> b
+foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm
+
+foldl' :: (b -> a -> b) -> b -> FM a -> b
+foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm
+
+foldl1 :: (a -> a -> a) -> FM a -> a
+foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm
+
+foldl1' :: (a -> a -> a) -> FM a -> a
+foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm
+
+foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b
+foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm
+
+foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b
+foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm
+
+foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b
+foldlWithKey f z fm = L.foldr (\(k,x) a -> f a k x) z . ordListFM_rev $ fm
+
+foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b
+foldlWithKey' f z fm = L.foldl' (\a (k,x) -> f a k x) z . ordListFM $ fm
+
+
+unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a
+unsafeFromOrdSeq = fromSeq
+
+unsafeAppend :: FM a -> FM a -> FM a
+unsafeAppend = union
+
+filterLT :: Int -> FM a -> FM a
+filterLT k = filterWithKey (\k' _ -> k' < k)
+
+filterLE :: Int -> FM a -> FM a
+filterLE k = filterWithKey (\k' _ -> k' <= k)
+
+filterGT :: Int -> FM a -> FM a
+filterGT k = filterWithKey (\k' _ -> k' > k)
+
+filterGE :: Int -> FM a -> FM a
+filterGE k = filterWithKey (\k' _ -> k' >= k)
+
+partitionLT_GE :: Int -> FM a -> (FM a, FM a)
+partitionLT_GE k fm = (filterLT k fm,filterGE k fm)
+
+partitionLE_GT :: Int -> FM a -> (FM a,FM a)
+partitionLE_GT k fm = (filterLE k fm,filterGT k fm)
+
+partitionLT_GT :: Int -> FM a -> (FM a,FM a)
+partitionLT_GT k fm = (filterLT k fm,filterGT k fm)
+
+toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a)
+toOrdSeq = L.foldr S.lcons S.empty . ordListFM
+
+-- defaults
+
+insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a
+insertSeq = insertSeqUsingFoldr
+
+unionSeq :: S.Sequence seq => seq (FM a) -> FM a
+unionSeq = unionSeqUsingReduce
+
+deleteAll :: Int -> FM a -> FM a
+deleteAll = delete
+
+deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a
+deleteSeq = deleteSeqUsingFoldr
+
+count :: Int -> FM a -> Int
+count = countUsingMember
+
+lookupAll :: S.Sequence seq => Int -> FM a -> seq a
+lookupAll = lookupAllUsingLookupM
+
+lookupWithDefault :: a -> Int -> FM a -> a
+lookupWithDefault = lookupWithDefaultUsingLookupM
+
+elements :: S.Sequence seq => FM a -> seq a
+elements = elementsUsingFold
+
+fromSeqWithKey ::
+    S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a
+fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey
+
+insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a
+insertWithKey = insertWithKeyUsingInsertWith
+
+insertSeqWith ::
+    S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a
+insertSeqWith = insertSeqWithUsingInsertWith
+
+insertSeqWithKey ::
+    S.Sequence seq =>
+      (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a
+insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey
+
+adjustAll :: (a -> a) -> Int -> FM a -> FM a
+adjustAll = adjust
+
+unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a
+unionSeqWith = unionSeqWithUsingReduce
+
+toSeq :: S.Sequence seq => FM a -> seq (Int,a)
+toSeq = toSeqUsingFoldWithKey
+
+keys :: S.Sequence seq => FM a -> seq Int
+keys = keysUsingFoldWithKey
+
+unionSeqWithKey ::
+    S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a
+unionSeqWithKey = unionSeqWithKeyUsingReduce
+
+-- instance declarations
+
+instance A.AssocX FM Int where
+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; union = union; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;
+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;
+   lookupAndDeleteAll = lookupAndDeleteAll;
+   lookupWithDefault = lookupWithDefault; adjust = adjust;
+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;
+   adjustAllOrInsert = adjustAllOrInsert;
+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; elements = elements;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance A.Assoc FM Int where
+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;
+   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';
+   filterWithKey = filterWithKey;
+   partitionWithKey = partitionWithKey}
+
+instance A.FiniteMapX FM Int where
+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;
+   insertWith = insertWith; insertWithKey = insertWithKey;
+   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;
+   unionl = unionl; unionr = unionr; unionWith = unionWith;
+   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;
+   difference = difference; properSubset = properSubset; subset = subset;
+   properSubmapBy = properSubmapBy; submapBy = submapBy;
+   sameMapBy = sameMapBy}
+
+instance A.FiniteMap FM Int where
+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;
+   intersectionWithKey = intersectionWithKey}
+
+instance A.OrdAssocX FM Int where
+  {minView = minView; minElem = minElem; deleteMin = deleteMin;
+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;
+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance A.OrdAssoc FM Int where
+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;
+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;
+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';
+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';
+   toOrdSeq = toOrdSeq}
+
+instance A.OrdFiniteMapX FM Int
+instance A.OrdFiniteMap FM Int
+
+instance Functor FM where
+  fmap = map
+
+instance (Show a) => Show (FM a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Read a) => Read (FM a) where
+  readsPrec = readsPrecUsingFromList
+
+instance (Eq a) => Eq (FM a) where
+  (==) = sameMap
+
+instance (Ord a) => Ord (FM a) where
+  compare = compareUsingToOrdList
+
+instance (Arbitrary a) => Arbitrary (FM a) where
+   arbitrary = do (xs::[(Int,a)]) <- arbitrary
+                  return (Prelude.foldr (uncurry insert) empty xs)
+
+instance (CoArbitrary a) => CoArbitrary (FM a) where
+   coarbitrary E = variant (0 :: Int)
+   coarbitrary (L i a) = variant (1 :: Int) . coarbitrary i . coarbitrary a
+   coarbitrary (B i j m n) = variant (2 :: Int) . coarbitrary i . coarbitrary j
+                           . coarbitrary m . coarbitrary n
+
+
+instance Semigroup (FM a) where
+   (<>) = union
+instance Monoid (FM a) where
+   mempty  = empty
+   mappend = (SG.<>)
+   mconcat = unionSeq

src/Data/Edison/Assoc/StandardMap.hs view

@@ -1,362 +1,362 @@--- |---   Module      :  Data.Edison.Assoc.AssocList---   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   The standard library "Data.Map" repackaged as an Edison---   associative collection.--module Data.Edison.Assoc.StandardMap (-    -- * Type of standard finite maps-    FM,--    -- * AssocX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,-    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,-    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,-    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,-    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,--    -- * FiniteMapX operations-    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,-    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,-    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,-    properSubmap,submap,sameMap,--    -- * OrdAssocX operations-    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,-    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',-    foldl1, foldl1', unsafeFromOrdSeq,-    unsafeAppend, filterLT, filterLE, filterGT, filterGE,-    partitionLT_GE, partitionLE_GT, partitionLT_GT,--    -- * Assoc operations-    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,--    -- * OrdAssoc operations-    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,-    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,--    -- * FiniteMap operations-    unionWithKey,unionSeqWithKey,intersectionWithKey,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)-import qualified Prelude-import qualified Control.Monad.Fail as Fail-import qualified Data.Edison.Assoc as A-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Assoc.Defaults-import Data.Int-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))--import qualified Data.Map as DM--type FM = DM.Map--moduleName :: String-moduleName = "Data.Edison.Assoc.StandardMap"--empty             :: FM k a-singleton         :: Ord k => k -> a -> FM k a-fromSeq           :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-insert            :: Ord k => k -> a -> FM k a -> FM k a-insertSeq         :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a-union             :: Ord k => FM k a -> FM k a -> FM k a-unionSeq          :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a-delete            :: Ord k => k -> FM k a -> FM k a-deleteAll         :: Ord k => k -> FM k a -> FM k a-deleteSeq         :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a-null              :: FM k a -> Bool-size              :: FM k a -> Int-member            :: Ord k => k -> FM k a -> Bool-count             :: Ord k => k -> FM k a -> Int-lookup            :: Ord k => k -> FM k a -> a-lookupAll         :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a-lookupM           :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m a-lookupWithDefault :: Ord k => a -> k -> FM k a -> a-lookupAndDelete   :: Ord k => k -> FM k a -> (a, FM k a)-lookupAndDeleteM  :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m (a, FM k a)-lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)-adjust            :: Ord k => (a->a) -> k -> FM k a -> FM k a-adjustAll         :: Ord k => (a->a) -> k -> FM k a -> FM k a-adjustOrInsert    :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustOrDelete    :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a-adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a-strict            :: Ord k => FM k a -> FM k a-strictWith        :: Ord k => (a -> b) -> FM k a -> FM k a-map               :: Ord k => (a -> b) -> FM k a -> FM k b-fold              :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1             :: Ord k => (a -> a -> a) -> FM k a -> a-fold'             :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1'            :: Ord k => (a -> a -> a) -> FM k a -> a-filter            :: Ord k => (a -> Bool) -> FM k a -> FM k a-partition         :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a)-elements          :: (Ord k,S.Sequence seq) => FM k a -> seq a--minView           :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a)-minElem           :: Ord k => FM k a -> a-deleteMin         :: Ord k => FM k a -> FM k a-unsafeInsertMin   :: Ord k => k -> a -> FM k a -> FM k a-maxView           :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a)-maxElem           :: Ord k => FM k a -> a-deleteMax         :: Ord k => FM k a -> FM k a-unsafeInsertMax   :: Ord k => k -> a -> FM k a -> FM k a-foldr             :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldl             :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldr1            :: Ord k => (a -> a -> a) -> FM k a -> a-foldl1            :: Ord k => (a -> a -> a) -> FM k a -> a-foldr'            :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldl'            :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldr1'           :: Ord k => (a -> a -> a) -> FM k a -> a-foldl1'           :: Ord k => (a -> a -> a) -> FM k a -> a-unsafeFromOrdSeq  :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-unsafeAppend      :: Ord k => FM k a -> FM k a -> FM k a-filterLT          :: Ord k => k -> FM k a -> FM k a-filterGT          :: Ord k => k -> FM k a -> FM k a-filterLE          :: Ord k => k -> FM k a -> FM k a-filterGE          :: Ord k => k -> FM k a -> FM k a-partitionLT_GE    :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLE_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLT_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)--fromSeqWith       :: (Ord k,S.Sequence seq) => (a -> a -> a)-                         -> seq (k,a) -> FM k a-fromSeqWithKey    :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)-                         -> seq (k,a) -> FM k a-insertWith        :: Ord k => (a -> a -> a) -> k -> a-                         -> FM k a -> FM k a-insertWithKey     :: Ord k => (k -> a -> a -> a) -> k -> a-                         -> FM k a -> FM k a-insertSeqWith     :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a)-                         -> FM k a -> FM k a-insertSeqWithKey  :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a)-                         -> FM k a -> FM k a-unionl            :: Ord k => FM k a -> FM k a -> FM k a-unionr            :: Ord k => FM k a -> FM k a -> FM k a-unionWith         :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith      :: (Ord k,S.Sequence seq) =>-                         (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith  :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference        :: Ord k => FM k a -> FM k b -> FM k a-properSubset      :: Ord k => FM k a -> FM k b -> Bool-subset            :: Ord k => FM k a -> FM k b -> Bool-properSubmapBy    :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy          :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap      :: (Ord k,Eq a) => FM k a -> FM k a -> Bool-submap            :: (Ord k,Eq a) => FM k a -> FM k a -> Bool-sameMap           :: (Ord k,Eq a) => FM k a -> FM k a -> Bool--toSeq             :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)-keys              :: (Ord k,S.Sequence seq) => FM k a -> seq k-mapWithKey        :: Ord k => (k -> a -> b) -> FM k a -> FM k b-foldWithKey       :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldWithKey'      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-filterWithKey     :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a-partitionWithKey  :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a)--minViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)-minElemWithKey    :: Ord k => FM k a -> (k,a)-maxViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)-maxElemWithKey    :: Ord k => FM k a -> (k,a)-foldrWithKey      :: (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey      :: (b -> k -> a -> b) -> b -> FM k a -> b-foldrWithKey'     :: (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey'     :: (b -> k -> a -> b) -> b -> FM k a -> b-toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)--unionWithKey      :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey   :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)-                        -> seq (FM k a) -> FM k a-intersectionWithKey  :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c--structuralInvariant :: Ord k => FM k a -> Bool-structuralInvariant = DM.valid---empty              = DM.empty-singleton          = DM.singleton-fromSeq            = fromSeqUsingInsertSeq-insert             = DM.insert-insertSeq          = insertSeqUsingFoldr-union              = DM.union-unionSeq           = DM.unions . S.toList-delete             = DM.delete-deleteAll          = DM.delete -- by finite map property-deleteSeq          = deleteSeqUsingFoldr-null               = DM.null-size               = DM.size-member             = DM.member-count              = countUsingMember-lookup k m         = maybe (error (moduleName ++ ".lookup: failed")) id (DM.lookup k m)-lookupM k m        = maybe (fail (moduleName ++ ".lookupM: failed")) return (DM.lookup k m)-lookupAll          = lookupAllUsingLookupM-lookupWithDefault  = DM.findWithDefault-lookupAndDelete    = lookupAndDeleteDefault-lookupAndDeleteM   = lookupAndDeleteMDefault-lookupAndDeleteAll = lookupAndDeleteAllDefault-adjust             = DM.adjust-adjustAll          = DM.adjust-adjustOrInsert     = adjustOrInsertUsingMember-adjustAllOrInsert  = adjustOrInsertUsingMember-adjustOrDelete     = DM.update-adjustOrDeleteAll  = DM.update-strict xs          = DM.foldr (flip const) () xs `seq` xs-strictWith f xs    = DM.foldr (\x z -> f x `seq` z) () xs `seq` xs-map                = fmap-fold               = DM.foldr-fold' f x xs       = L.foldl' (flip f) x (DM.elems xs)-fold1  f xs        = L.foldr1 f (DM.elems xs)-fold1' f xs        = L.foldl1' (flip f) (DM.elems xs)-filter             = DM.filter-partition          = DM.partition-elements           = elementsUsingFold--minView m          = if DM.null m-                       then fail (moduleName ++ ".minView: failed")-                       else let ((_,x),m') = DM.deleteFindMin m-                            in return (x,m')-minElem            = snd . DM.findMin-deleteMin          = DM.deleteMin-unsafeInsertMin    = DM.insert-maxView m          = if DM.null m-                       then fail (moduleName ++ ".maxView: failed")-                       else let ((_,x),m') = DM.deleteFindMax m-                            in return (x,m')-maxElem            = snd . DM.findMax-deleteMax          = DM.deleteMax-unsafeInsertMax    = DM.insert-foldr   f x m      = L.foldr   f x (DM.elems m)-foldl   f x m      = L.foldl   f x (DM.elems m)-foldr1  f   m      = L.foldr1  f   (DM.elems m)-foldl1  f   m      = L.foldl1  f   (DM.elems m)-foldr'  f x m      = L.foldr'  f x (DM.elems m)-foldl'  f x m      = L.foldl'  f x (DM.elems m)-foldr1' f   m      = L.foldr1' f   (DM.elems m)-foldl1' f   m      = L.foldl1' f   (DM.elems m)-unsafeFromOrdSeq   = DM.fromAscList . S.toList-unsafeAppend       = DM.union-filterLT k         = fst . DM.split k-filterGT k         = snd . DM.split k-filterLE k m       = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx-filterGE k m       = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx-partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx)-partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt)-partitionLT_GT     = DM.split-fromSeqWith    f s = DM.fromListWith    f (S.toList s)-fromSeqWithKey f s = DM.fromListWithKey f (S.toList s)-insertWith         = DM.insertWith-insertWithKey      = insertWithKeyUsingInsertWith-insertSeqWith      = insertSeqWithUsingInsertWith-insertSeqWithKey   = insertSeqWithKeyUsingInsertWithKey-unionl             = DM.union-unionr             = flip DM.union-unionWith          = DM.unionWith-unionSeqWith       = unionSeqWithUsingReduce-intersectionWith   = DM.intersectionWith-difference         = DM.difference-properSubset       = DM.isProperSubmapOfBy (\_ _ -> True)-subset             = DM.isSubmapOfBy (\_ _ -> True)-properSubmapBy     = DM.isProperSubmapOfBy-submapBy           = DM.isSubmapOfBy-sameMapBy          = sameMapByUsingOrdLists-properSubmap       = A.properSubmap-submap             = A.submap-sameMap            = A.sameMap--toSeq              = toSeqUsingFoldWithKey-keys               = keysUsingFoldWithKey-mapWithKey         = DM.mapWithKey-foldWithKey        = DM.foldrWithKey-foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m)-filterWithKey      = DM.filterWithKey-partitionWithKey   = DM.partitionWithKey--minViewWithKey m   = if DM.null m-                        then fail (moduleName ++ ".minViewWithKey: failed")-                        else return (DM.deleteFindMin m)-minElemWithKey     = DM.findMin-maxViewWithKey m   = if DM.null m-                        then fail (moduleName ++ ".maxViewWithKey: failed")-                        else return (DM.deleteFindMax m)-maxElemWithKey     = DM.findMax-foldrWithKey        = DM.foldrWithKey-foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m)-foldlWithKey  f x m = L.foldl  (\b (k,a) -> f b k a) x (DM.toAscList m)-foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m)-toOrdSeq           = S.fromList . DM.toAscList--unionWithKey       = DM.unionWithKey-unionSeqWithKey    = unionSeqWithKeyUsingReduce-intersectionWithKey = DM.intersectionWithKey---instance Ord k => A.AssocX (FM k) k where-  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; union = union; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;-   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;-   lookupAndDeleteAll = lookupAndDeleteAll;-   lookupWithDefault = lookupWithDefault; adjust = adjust;-   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;-   adjustAllOrInsert = adjustAllOrInsert;-   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; elements = elements;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k => A.OrdAssocX (FM k) k where-  {minView = minView; minElem = minElem; deleteMin = deleteMin;-   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;-   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord k => A.FiniteMapX (FM k) k where-  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;-   insertWith = insertWith; insertWithKey = insertWithKey;-   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;-   unionl = unionl; unionr = unionr; unionWith = unionWith;-   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;-   difference = difference; properSubset = properSubset; subset = subset;-   properSubmapBy = properSubmapBy; submapBy = submapBy;-   sameMapBy = sameMapBy}--instance Ord k => A.OrdFiniteMapX (FM k) k--instance Ord k => A.Assoc (FM k) k where-  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;-   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';-   filterWithKey = filterWithKey;-   partitionWithKey = partitionWithKey}--instance Ord k => A.OrdAssoc (FM k) k where-  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;-   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;-   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';-   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';-   toOrdSeq = toOrdSeq}--instance Ord k => A.FiniteMap (FM k) k where-  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;-   intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdFiniteMap (FM k) k+-- |
+--   Module      :  Data.Edison.Assoc.AssocList
+--   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   The standard library "Data.Map" repackaged as an Edison
+--   associative collection.
+
+module Data.Edison.Assoc.StandardMap (
+    -- * Type of standard finite maps
+    FM,
+
+    -- * AssocX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,
+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,
+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,
+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,
+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,
+
+    -- * FiniteMapX operations
+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,
+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,
+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,
+    properSubmap,submap,sameMap,
+
+    -- * OrdAssocX operations
+    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,
+    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',
+    foldl1, foldl1', unsafeFromOrdSeq,
+    unsafeAppend, filterLT, filterLE, filterGT, filterGE,
+    partitionLT_GE, partitionLE_GT, partitionLT_GT,
+
+    -- * Assoc operations
+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,
+
+    -- * OrdAssoc operations
+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,
+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,
+
+    -- * FiniteMap operations
+    unionWithKey,unionSeqWithKey,intersectionWithKey,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
+import qualified Prelude
+import qualified Control.Monad.Fail as Fail
+import qualified Data.Edison.Assoc as A
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Assoc.Defaults
+import Data.Int
+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))
+
+import qualified Data.Map as DM
+
+type FM = DM.Map
+
+moduleName :: String
+moduleName = "Data.Edison.Assoc.StandardMap"
+
+empty             :: FM k a
+singleton         :: Ord k => k -> a -> FM k a
+fromSeq           :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a
+insert            :: Ord k => k -> a -> FM k a -> FM k a
+insertSeq         :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a
+union             :: Ord k => FM k a -> FM k a -> FM k a
+unionSeq          :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a
+delete            :: Ord k => k -> FM k a -> FM k a
+deleteAll         :: Ord k => k -> FM k a -> FM k a
+deleteSeq         :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a
+null              :: FM k a -> Bool
+size              :: FM k a -> Int
+member            :: Ord k => k -> FM k a -> Bool
+count             :: Ord k => k -> FM k a -> Int
+lookup            :: Ord k => k -> FM k a -> a
+lookupAll         :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a
+lookupM           :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m a
+lookupWithDefault :: Ord k => a -> k -> FM k a -> a
+lookupAndDelete   :: Ord k => k -> FM k a -> (a, FM k a)
+lookupAndDeleteM  :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m (a, FM k a)
+lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)
+adjust            :: Ord k => (a->a) -> k -> FM k a -> FM k a
+adjustAll         :: Ord k => (a->a) -> k -> FM k a -> FM k a
+adjustOrInsert    :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a
+adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a
+adjustOrDelete    :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a
+adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a
+strict            :: Ord k => FM k a -> FM k a
+strictWith        :: Ord k => (a -> b) -> FM k a -> FM k a
+map               :: Ord k => (a -> b) -> FM k a -> FM k b
+fold              :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+fold1             :: Ord k => (a -> a -> a) -> FM k a -> a
+fold'             :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+fold1'            :: Ord k => (a -> a -> a) -> FM k a -> a
+filter            :: Ord k => (a -> Bool) -> FM k a -> FM k a
+partition         :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a)
+elements          :: (Ord k,S.Sequence seq) => FM k a -> seq a
+
+minView           :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a)
+minElem           :: Ord k => FM k a -> a
+deleteMin         :: Ord k => FM k a -> FM k a
+unsafeInsertMin   :: Ord k => k -> a -> FM k a -> FM k a
+maxView           :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a)
+maxElem           :: Ord k => FM k a -> a
+deleteMax         :: Ord k => FM k a -> FM k a
+unsafeInsertMax   :: Ord k => k -> a -> FM k a -> FM k a
+foldr             :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldl             :: Ord k => (b -> a -> b) -> b -> FM k a -> b
+foldr1            :: Ord k => (a -> a -> a) -> FM k a -> a
+foldl1            :: Ord k => (a -> a -> a) -> FM k a -> a
+foldr'            :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldl'            :: Ord k => (b -> a -> b) -> b -> FM k a -> b
+foldr1'           :: Ord k => (a -> a -> a) -> FM k a -> a
+foldl1'           :: Ord k => (a -> a -> a) -> FM k a -> a
+unsafeFromOrdSeq  :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a
+unsafeAppend      :: Ord k => FM k a -> FM k a -> FM k a
+filterLT          :: Ord k => k -> FM k a -> FM k a
+filterGT          :: Ord k => k -> FM k a -> FM k a
+filterLE          :: Ord k => k -> FM k a -> FM k a
+filterGE          :: Ord k => k -> FM k a -> FM k a
+partitionLT_GE    :: Ord k => k -> FM k a -> (FM k a,FM k a)
+partitionLE_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)
+partitionLT_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)
+
+fromSeqWith       :: (Ord k,S.Sequence seq) => (a -> a -> a)
+                         -> seq (k,a) -> FM k a
+fromSeqWithKey    :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)
+                         -> seq (k,a) -> FM k a
+insertWith        :: Ord k => (a -> a -> a) -> k -> a
+                         -> FM k a -> FM k a
+insertWithKey     :: Ord k => (k -> a -> a -> a) -> k -> a
+                         -> FM k a -> FM k a
+insertSeqWith     :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a)
+                         -> FM k a -> FM k a
+insertSeqWithKey  :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a)
+                         -> FM k a -> FM k a
+unionl            :: Ord k => FM k a -> FM k a -> FM k a
+unionr            :: Ord k => FM k a -> FM k a -> FM k a
+unionWith         :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWith      :: (Ord k,S.Sequence seq) =>
+                         (a -> a -> a) -> seq (FM k a) -> FM k a
+intersectionWith  :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c
+difference        :: Ord k => FM k a -> FM k b -> FM k a
+properSubset      :: Ord k => FM k a -> FM k b -> Bool
+subset            :: Ord k => FM k a -> FM k b -> Bool
+properSubmapBy    :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+submapBy          :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+sameMapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+properSubmap      :: (Ord k,Eq a) => FM k a -> FM k a -> Bool
+submap            :: (Ord k,Eq a) => FM k a -> FM k a -> Bool
+sameMap           :: (Ord k,Eq a) => FM k a -> FM k a -> Bool
+
+toSeq             :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)
+keys              :: (Ord k,S.Sequence seq) => FM k a -> seq k
+mapWithKey        :: Ord k => (k -> a -> b) -> FM k a -> FM k b
+foldWithKey       :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b
+foldWithKey'      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b
+filterWithKey     :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a
+partitionWithKey  :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a)
+
+minViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)
+minElemWithKey    :: Ord k => FM k a -> (k,a)
+maxViewWithKey    :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a)
+maxElemWithKey    :: Ord k => FM k a -> (k,a)
+foldrWithKey      :: (k -> a -> b -> b) -> b -> FM k a -> b
+foldlWithKey      :: (b -> k -> a -> b) -> b -> FM k a -> b
+foldrWithKey'     :: (k -> a -> b -> b) -> b -> FM k a -> b
+foldlWithKey'     :: (b -> k -> a -> b) -> b -> FM k a -> b
+toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)
+
+unionWithKey      :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWithKey   :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)
+                        -> seq (FM k a) -> FM k a
+intersectionWithKey  :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c
+
+structuralInvariant :: Ord k => FM k a -> Bool
+structuralInvariant = DM.valid
+
+
+empty              = DM.empty
+singleton          = DM.singleton
+fromSeq            = fromSeqUsingInsertSeq
+insert             = DM.insert
+insertSeq          = insertSeqUsingFoldr
+union              = DM.union
+unionSeq           = DM.unions . S.toList
+delete             = DM.delete
+deleteAll          = DM.delete -- by finite map property
+deleteSeq          = deleteSeqUsingFoldr
+null               = DM.null
+size               = DM.size
+member             = DM.member
+count              = countUsingMember
+lookup k m         = maybe (error (moduleName ++ ".lookup: failed")) id (DM.lookup k m)
+lookupM k m        = maybe (fail (moduleName ++ ".lookupM: failed")) return (DM.lookup k m)
+lookupAll          = lookupAllUsingLookupM
+lookupWithDefault  = DM.findWithDefault
+lookupAndDelete    = lookupAndDeleteDefault
+lookupAndDeleteM   = lookupAndDeleteMDefault
+lookupAndDeleteAll = lookupAndDeleteAllDefault
+adjust             = DM.adjust
+adjustAll          = DM.adjust
+adjustOrInsert     = adjustOrInsertUsingMember
+adjustAllOrInsert  = adjustOrInsertUsingMember
+adjustOrDelete     = DM.update
+adjustOrDeleteAll  = DM.update
+strict xs          = DM.foldr (flip const) () xs `seq` xs
+strictWith f xs    = DM.foldr (\x z -> f x `seq` z) () xs `seq` xs
+map                = fmap
+fold               = DM.foldr
+fold' f x xs       = L.foldl' (flip f) x (DM.elems xs)
+fold1  f xs        = L.foldr1 f (DM.elems xs)
+fold1' f xs        = L.foldl1' (flip f) (DM.elems xs)
+filter             = DM.filter
+partition          = DM.partition
+elements           = elementsUsingFold
+
+minView m          = if DM.null m
+                       then fail (moduleName ++ ".minView: failed")
+                       else let ((_,x),m') = DM.deleteFindMin m
+                            in return (x,m')
+minElem            = snd . DM.findMin
+deleteMin          = DM.deleteMin
+unsafeInsertMin    = DM.insert
+maxView m          = if DM.null m
+                       then fail (moduleName ++ ".maxView: failed")
+                       else let ((_,x),m') = DM.deleteFindMax m
+                            in return (x,m')
+maxElem            = snd . DM.findMax
+deleteMax          = DM.deleteMax
+unsafeInsertMax    = DM.insert
+foldr   f x m      = L.foldr   f x (DM.elems m)
+foldl   f x m      = L.foldl   f x (DM.elems m)
+foldr1  f   m      = L.foldr1  f   (DM.elems m)
+foldl1  f   m      = L.foldl1  f   (DM.elems m)
+foldr'  f x m      = L.foldr'  f x (DM.elems m)
+foldl'  f x m      = L.foldl'  f x (DM.elems m)
+foldr1' f   m      = L.foldr1' f   (DM.elems m)
+foldl1' f   m      = L.foldl1' f   (DM.elems m)
+unsafeFromOrdSeq   = DM.fromAscList . S.toList
+unsafeAppend       = DM.union
+filterLT k         = fst . DM.split k
+filterGT k         = snd . DM.split k
+filterLE k m       = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx
+filterGE k m       = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx
+partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx)
+partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt)
+partitionLT_GT     = DM.split
+fromSeqWith    f s = DM.fromListWith    f (S.toList s)
+fromSeqWithKey f s = DM.fromListWithKey f (S.toList s)
+insertWith         = DM.insertWith
+insertWithKey      = insertWithKeyUsingInsertWith
+insertSeqWith      = insertSeqWithUsingInsertWith
+insertSeqWithKey   = insertSeqWithKeyUsingInsertWithKey
+unionl             = DM.union
+unionr             = flip DM.union
+unionWith          = DM.unionWith
+unionSeqWith       = unionSeqWithUsingReduce
+intersectionWith   = DM.intersectionWith
+difference         = DM.difference
+properSubset       = DM.isProperSubmapOfBy (\_ _ -> True)
+subset             = DM.isSubmapOfBy (\_ _ -> True)
+properSubmapBy     = DM.isProperSubmapOfBy
+submapBy           = DM.isSubmapOfBy
+sameMapBy          = sameMapByUsingOrdLists
+properSubmap       = A.properSubmap
+submap             = A.submap
+sameMap            = A.sameMap
+
+toSeq              = toSeqUsingFoldWithKey
+keys               = keysUsingFoldWithKey
+mapWithKey         = DM.mapWithKey
+foldWithKey        = DM.foldrWithKey
+foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m)
+filterWithKey      = DM.filterWithKey
+partitionWithKey   = DM.partitionWithKey
+
+minViewWithKey m   = if DM.null m
+                        then fail (moduleName ++ ".minViewWithKey: failed")
+                        else return (DM.deleteFindMin m)
+minElemWithKey     = DM.findMin
+maxViewWithKey m   = if DM.null m
+                        then fail (moduleName ++ ".maxViewWithKey: failed")
+                        else return (DM.deleteFindMax m)
+maxElemWithKey     = DM.findMax
+foldrWithKey        = DM.foldrWithKey
+foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m)
+foldlWithKey  f x m = L.foldl  (\b (k,a) -> f b k a) x (DM.toAscList m)
+foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m)
+toOrdSeq           = S.fromList . DM.toAscList
+
+unionWithKey       = DM.unionWithKey
+unionSeqWithKey    = unionSeqWithKeyUsingReduce
+intersectionWithKey = DM.intersectionWithKey
+
+
+instance Ord k => A.AssocX (FM k) k where
+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; union = union; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;
+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;
+   lookupAndDeleteAll = lookupAndDeleteAll;
+   lookupWithDefault = lookupWithDefault; adjust = adjust;
+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;
+   adjustAllOrInsert = adjustAllOrInsert;
+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; elements = elements;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord k => A.OrdAssocX (FM k) k where
+  {minView = minView; minElem = minElem; deleteMin = deleteMin;
+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;
+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord k => A.FiniteMapX (FM k) k where
+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;
+   insertWith = insertWith; insertWithKey = insertWithKey;
+   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;
+   unionl = unionl; unionr = unionr; unionWith = unionWith;
+   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;
+   difference = difference; properSubset = properSubset; subset = subset;
+   properSubmapBy = properSubmapBy; submapBy = submapBy;
+   sameMapBy = sameMapBy}
+
+instance Ord k => A.OrdFiniteMapX (FM k) k
+
+instance Ord k => A.Assoc (FM k) k where
+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;
+   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';
+   filterWithKey = filterWithKey;
+   partitionWithKey = partitionWithKey}
+
+instance Ord k => A.OrdAssoc (FM k) k where
+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;
+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;
+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';
+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';
+   toOrdSeq = toOrdSeq}
+
+instance Ord k => A.FiniteMap (FM k) k where
+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;
+   intersectionWithKey = intersectionWithKey}
+
+instance Ord k => A.OrdFiniteMap (FM k) k

src/Data/Edison/Assoc/TernaryTrie.hs view

@@ -1,1170 +1,1300 @@--- |---   Module      :  Data.Edison.Assoc.TernaryTrie---   Copyright   :  Copyright (c) 2002, 2008 Andrew Bromage---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Finite maps implemented as ternary search tries--module Data.Edison.Assoc.TernaryTrie (-    -- * Type of ternary search tries-    FM,--    -- * AssocX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,-    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,-    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,-    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,-    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,--    -- * Assoc operations-    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,--    -- * FiniteMapX operations-    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,-    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,-    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,-    properSubmap,submap,sameMap,--    -- * FiniteMap operations-    unionWithKey,unionSeqWithKey,intersectionWithKey,--    -- * OrdAssocX operations-    minView, minElem, deleteMin, unsafeInsertMin,-    maxView, maxElem, deleteMax, unsafeInsertMax,-    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',-    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,-    partitionLT_GE, partitionLE_GT, partitionLT_GT,--    -- * OrdAssoc operations-    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,-    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',-    toOrdSeq,--    -- * Other supported operations-    mergeVFM, mergeKVFM,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)-import qualified Prelude-import qualified Data.Edison.Assoc as A-import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S-import qualified Data.List as L-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Monoid-import Data.Semigroup as SG-import Data.Maybe (isNothing)--import Data.Edison.Assoc.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), variant)----- signatures for exported functions-moduleName    :: String-empty         :: Ord k => FM k a-singleton     :: Ord k => [k] -> a -> FM k a-fromSeq       :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a-insert        :: Ord k => [k] -> a -> FM k a -> FM k a-insertSeq     :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a-union         :: Ord k => FM k a -> FM k a -> FM k a-unionSeq      :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a-delete        :: Ord k => [k] -> FM k a -> FM k a-deleteAll     :: Ord k => [k] -> FM k a -> FM k a-deleteSeq     :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a-null          :: Ord k => FM k a -> Bool-size          :: Ord k => FM k a -> Int-member        :: Ord k => [k] -> FM k a -> Bool-count         :: Ord k => [k] -> FM k a -> Int-lookup        :: Ord k => [k] -> FM k a -> a-lookupM       :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm a-lookupAll     :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a-lookupAndDelete    :: Ord k => [k] -> FM k a -> (a, FM k a)-lookupAndDeleteM   :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm (a, FM k a)-lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a)-lookupWithDefault  :: Ord k => a -> [k] -> FM k a -> a-adjust        :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a-adjustAll     :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a-adjustOrInsert    :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a-adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a-adjustOrDelete    :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a-adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a-strict            :: FM k a -> FM k a-strictWith        :: (a -> b) -> FM k a -> FM k a-map           :: Ord k => (a -> b) -> FM k a -> FM k b-fold          :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1         :: Ord k => (a -> a -> a) -> FM k a -> a-fold'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1'        :: Ord k => (a -> a -> a) -> FM k a -> a-filter        :: Ord k => (a -> Bool) -> FM k a -> FM k a-partition     :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a)-elements      :: (Ord k,S.Sequence seq) => FM k a -> seq a--fromSeqWith      :: (Ord k,S.Sequence seq) =>-                        (a -> a -> a) -> seq ([k],a) -> FM k a-fromSeqWithKey   :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a-insertWith       :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a-insertWithKey    :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a-insertSeqWith    :: (Ord k,S.Sequence seq) =>-                        (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a-insertSeqWithKey :: (Ord k,S.Sequence seq) =>-                        ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a-unionl           :: Ord k => FM k a -> FM k a -> FM k a-unionr           :: Ord k => FM k a -> FM k a -> FM k a-unionWith        :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith     :: (Ord k,S.Sequence seq) =>-                        (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference       :: Ord k => FM k a -> FM k b -> FM k a-properSubset     :: Ord k => FM k a -> FM k b -> Bool-subset           :: Ord k => FM k a -> FM k b -> Bool-properSubmapBy   :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy        :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap     :: (Ord k, Eq a) => FM k a -> FM k a -> Bool-submap           :: (Ord k, Eq a) => FM k a -> FM k a -> Bool-sameMap          :: (Ord k, Eq a) => FM k a -> FM k a -> Bool--toSeq            :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)-keys             :: (Ord k,S.Sequence seq) => FM k a -> seq [k]-mapWithKey       :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b-foldWithKey      :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldWithKey'     :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-filterWithKey    :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a-partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a)-unionWithKey     :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey  :: (Ord k,S.Sequence seq) =>-                       ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c--foldr          :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1         :: Ord k => (a -> a -> a) -> FM k a -> a-foldr'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1'        :: Ord k => (a -> a -> a) -> FM k a -> a--foldrWithKey   :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldrWithKey'  :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey   :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b-foldlWithKey'  :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b-toOrdSeq       :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)--moduleName = "Data.Edison.Assoc.TernaryTrie"---data FM k a-  = FM !(Maybe a) !(FMB k a)--data FMB k v-  = E-  | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v)--newtype FMB' k v-  = FMB' (FMB k v)--balance :: Int-balance = 6--sizeFMB :: FMB k v -> Int-sizeFMB E = 0-sizeFMB (I size _ _ _ _ _) = size--mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkFMB k v l m r-  = I (1 + sizeFMB l + sizeFMB r) k v l m r--lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v-lookupFMB []        _-  = Nothing-lookupFMB (_:_) E-  = Nothing-lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r)-  = case compare x k of-        LT -> lookupFMB nk l-        GT -> lookupFMB nk r-        EQ -> if L.null xs then v else lookupFMB xs fmbm--listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v-listToFMB [x]    fv = mkFMB x (fv Nothing) E (FMB' E)                 E-listToFMB (x:xs) fv = mkFMB x Nothing      E (FMB' $ listToFMB xs fv) E-listToFMB _ _ = error "TernaryTrie.listToFMB: bug!"--addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v-addToFMB xs combiner E-  = listToFMB xs combiner-addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r)-  = case compare x k of-        LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r-        GT -> mkBalancedFMB k v l m (addToFMB nk combiner r)-        EQ -> case xs of-                [] -> I size k (combiner v) l m r-                _  -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r-addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!"--addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v-addToFM [] combiner (FM n fmb)-  = FM (combiner n) fmb-addToFM xs combiner (FM n fmb)-  = FM n (addToFMB xs combiner fmb)--lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z-lookupAndDelFromFMB onFail _ _ E = onFail-lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r)-  = case compare x k of-        LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l-        GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r-        EQ -> case xs of-                [] -> case v of-                        Nothing -> onFail-                        Just w  -> case fmbm of-                                      E -> cont w (appendFMB l r)-                                      _ -> cont w (I size k Nothing l m r)-                _  -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm-lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!"--lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z-lookupAndDelFromFM onFail _ [] (FM Nothing _)  = onFail-lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb)-lookupAndDelFromFM onFail cont xs (FM n fmb) =-   lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb---delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v-delFromFMB _ E-  = E-delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r)-  = case compare x k of-        LT -> mkBalancedFMB k v (delFromFMB nk l) m r-        GT -> mkBalancedFMB k v l m (delFromFMB nk r)-        EQ -> case xs of-                [] -> case fmbm of-                        E -> appendFMB l r-                        _ -> I size k Nothing l m r-                _  -> I size k v l (FMB' $ delFromFMB xs fmbm) r-delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!"---delFromFM :: (Ord k) => [k] -> FM k v -> FM k v-delFromFM [] (FM _ fmb)-  = FM Nothing fmb-delFromFM xs (FM n fmb)-  = FM n (delFromFMB xs fmb)---mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkBalancedFMB k v l m r-  | size_l + size_r < 2-    = mkFMB k v l m r-  | size_r > balance * size_l        -- Right tree too big-    = case r of-        I _ _ _ rl _ rr-            | sizeFMB rl < 2 * sizeFMB rr-                -> single_L l m r-            | otherwise-                -> double_L l m r-        _ -> error "TernaryTrie.mkBalancedFMB: bug!"--  | size_l > balance * size_r   -- Left tree too big-    = case l of-        I _ _ _ ll _ lr-            | sizeFMB lr < 2 * sizeFMB ll-                -> single_R l m r-            | otherwise-                -> double_R l m r-        _ -> error "TernaryTrie.mkBalancedFMB: bug!"--  | otherwise                           -- No imbalance-    = mkFMB k v l m r-  where-        size_l   = sizeFMB l-        size_r   = sizeFMB r--        single_L l m (I _ k_r v_r rl rm rr)-          = mkFMB k_r v_r (mkFMB k v l m rl) rm rr-        single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"--        double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr)-          = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr)-        double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"--        single_R (I _ k_l v_l ll lm lr) m r-          = mkFMB k_l v_l ll lm (mkFMB k v lr m r)-        single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"--        double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r-          = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r)-        double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"---mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkVBalancedFMB k v E m E-  = mkFMB k v E m E-mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr)-  = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr-mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E-  = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)-mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr)-  | balance * size_l < size_r-    = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr-  | balance * size_r < size_l-    = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)-  | otherwise-    = mkFMB k v l m r-  where-        size_l = sizeFMB l-        size_r = sizeFMB r--    -- Constraint: All keys in the first FMB are less than-    -- that in the second FMB.-appendFMB :: FMB k v -> FMB k v -> FMB k v-appendFMB E m2 = m2-appendFMB m1 E = m1-appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2)-  | size1 > size2-    = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2)-  | otherwise-    = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2--mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b-mapVFM f (FM n fmb)-  = FM (f n) (mapVFMB f fmb)--mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b-mapVFMB f m-  = mapVFMB' m-  where-        mapVFMB' E = E-        mapVFMB' (I _ k v l (FMB' m) r)-          = case (mapVFMB' m, f v) of-                (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r)-                (m',v')     -> mkVBalancedFMB k v'-                                    (mapVFMB' l) (FMB' m') (mapVFMB' r)--mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b-mapKVFM f (FM n fmb)-  = FM (f [] n) (mapKVFMB [] fmb)-  where-        mapKVFMB _ E = E-        mapKVFMB ks (I _ k v l (FMB' m) r)-          = mkVBalancedFMB k (f (reverse (k:ks)) v)-              (mapKVFMB ks l)-              (FMB' (mapKVFMB (k:ks) m))-              (mapKVFMB ks r)--nullFMB :: FMB k v -> Bool-nullFMB E = True-nullFMB (I _ _ v l (FMB' m) r)-  = case v of-      Just _  -> False-      Nothing -> nullFMB l && nullFMB m && nullFMB r--nullFM :: FM k v -> Bool-nullFM (FM (Just _) _)  = False-nullFM (FM Nothing fmb) = nullFMB fmb--data FMBCtx k v-  = T-  | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v)-  | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v)--splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a)-splayFMB key fmb-  = splaydown T fmb-  where-    splaydown ctx E-      = splayup ctx Nothing E (FMB' E) E-    splaydown ctx (I _ k v l m r)-      = case compare key k of-            LT -> splaydown (L k v ctx m r) l-            GT -> splaydown (R k v l m ctx) r-            EQ -> splayup ctx v l m r--    splayup ctx v l m r-      = splayup' ctx l r-      where-          splayup' T l r-            = (v, l, m, r)-          splayup' (L ck cv ctx cm cr) tl tr-            = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr)-          splayup' (R ck cv cl cm ctx) tl tr-            = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr--mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->-                FMB k a -> FMB k b -> FMB k c-mergeVFMB f fmbx fmby-  = mergeVFMB' fmbx fmby-  where-    mergeVFMB' E E-      = E-    mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _)-      = mapVFMB (\v -> f Nothing v) fmby-    mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E-      = mapVFMB (\v -> f v Nothing) fmbx-    mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx)-               fmby@(I sizey ky vy ly (FMB' my) ry)-      | sizex >= sizey-        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby-          in case (mergeVFMB' mx my, f vx vy) of-                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)-                (m',v)      -> mkVBalancedFMB kx v-                                   (mergeVFMB' lx ly)-                                   (FMB' m')-                                   (mergeVFMB' rx ry)-      | otherwise-        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx-          in case (mergeVFMB' mx my, f vx vy) of-                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)-                (m',v)      -> mkVBalancedFMB ky v-                                   (mergeVFMB' lx ly)-                                   (FMB' m')-                                   (mergeVFMB' rx ry)--mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->-                FM k a -> FM k b -> FM k c-mergeVFM f (FM vx fmbx) (FM vy fmby)-  = FM (f vx vy) (mergeVFMB f fmbx fmby)---mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->-                FMB k a -> FMB k b -> FMB k c-mergeKVFMB f fmbx fmby-  = mergeKVFMB' [] fmbx fmby-  where-    mergeKVFMB' _ E E-      = E-    mergeKVFMB' ks E fmby-      = mergeKVFMBs (\k v -> f k Nothing v) ks fmby-    mergeKVFMB' ks fmbx E-      = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx-    mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx)-                   fmby@(I sizey ky vy ly (FMB' my) ry)-      | sizex >= sizey-        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby-              ks' = reverse (kx:ks)-          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of-                (E,Nothing) -> appendFMB-                                    (mergeKVFMB' ks lx ly)-                                    (mergeKVFMB' ks rx ry)-                (m',v)      -> mkVBalancedFMB kx v-                                    (mergeKVFMB' ks lx ly)-                                    (FMB' m')-                                    (mergeKVFMB' ks rx ry)-      | otherwise-        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx-              ks' = reverse (ky:ks)-          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of-                (E,Nothing) -> appendFMB-                                    (mergeKVFMB' ks lx ly)-                                    (mergeKVFMB' ks rx ry)-                (m',v)      -> mkVBalancedFMB ky v-                                    (mergeKVFMB' ks lx ly)-                                    (FMB' m')-                                    (mergeKVFMB' ks rx ry)--    mergeKVFMBs f ks fmb-      = mergeKVFMBs' ks fmb-      where-          mergeKVFMBs' _ E-            = E-          mergeKVFMBs' ks (I _ k v l (FMB' m) r)-            = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of-                (E, Nothing) -> appendFMB-                                    (mergeKVFMBs' ks l)-                                    (mergeKVFMBs' ks r)-                (m,v)        -> mkVBalancedFMB k v-                                    (mergeKVFMBs' ks l)-                                    (FMB' m)-                                    (mergeKVFMBs' ks r)--mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->-                FM k a -> FM k b -> FM k c-mergeKVFM f (FM vx fmbx) (FM vy fmby)-  = FM (f [] vx vy) (mergeKVFMB f fmbx fmby)----- The public interface.------- AssocX--empty = FM Nothing E--singleton [] v = FM (Just v) E-singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v))--fromSeq = fromSeqUsingInsertSeq--insert k v fm = addToFM k (\_ -> Just v) fm--insertSeq = insertSeqUsingFoldr--union = mergeVFM mplus--unionSeq = unionSeqUsingReduce--delete k fm = delFromFM k fm--deleteAll = delete--deleteSeq = deleteSeqUsingFoldr--null = nullFM--size (FM k fmb)-    | isNothing k = fmb_size fmb 0-    | otherwise   = fmb_size fmb 1-    where fmb_size E k = k-          fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k-          fmb_size (I _ _ _ l (FMB' m) r ) k      = fmb_size l $ fmb_size m $ fmb_size r $! k+1---member = memberUsingLookupM--count = countUsingMember--lookup m k = runFail_ (lookupM m k)--lookupM [] (FM Nothing _)-  = fail "TernaryTrie.lookup: lookup failed"-lookupM [] (FM (Just v) _)-  = return v-lookupM xs (FM _ fmb)-  = case  lookupFMB xs fmb  of-        Nothing -> fail "TernaryTrie.lookup: lookup failed"-        Just v  -> return v--lookupAll = lookupAllUsingLookupM--lookupAndDelete =-    lookupAndDelFromFM-      (error "TernaryTrie.lookupAndDelete: lookup failed")-      (,)--lookupAndDeleteM =-    lookupAndDelFromFM-      (fail  "TernaryTrie.lookupAndDeleteM: lookup failed")-      (\w m -> return (w,m))--lookupAndDeleteAll k m =-    lookupAndDelFromFM-      (S.empty,m)-      (\w m' -> (S.singleton w,m'))-      k m--lookupWithDefault = lookupWithDefaultUsingLookupM--adjust f k-  = addToFM k (\mv -> case mv of-                        Nothing -> mv-                        Just v  -> Just (f v))--adjustAll = adjust--adjustOrInsert f z k-  = addToFM k (\mv -> case mv of-                        Nothing -> Just z-                        Just v  -> Just (f v))--adjustAllOrInsert = adjustOrInsert--adjustOrDelete f k-  = addToFM k (\mv -> case mv of-                        Nothing -> mv-                        Just v  -> f v)--adjustOrDeleteAll = adjustOrDelete--map f-  = mapVFM (\mv -> case mv of-                        Nothing -> Nothing-                        Just v  -> Just (f v))--fold = foldr-fold' = foldr'--foldr op z (FM n fmb)-  = foldMV n . foldFMB fmb $ z-  where-    foldMV Nothing  = id-    foldMV (Just v) = op v--    foldFMB E-      = id-    foldFMB (I _ _ v l (FMB' m) r)-      = foldFMB l . foldMV v . foldFMB m . foldFMB r--foldrWithKey f z (FM n fmb)-  = foldMV [] n . foldFMB id fmb $ z-  where-     foldMV _ Nothing  = id-     foldMV ks (Just v) = f ks v--     foldFMB _ E = id-     foldFMB kf (I _ k mv l (FMB' m) r)-       = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r--foldlWithKey f z (FM n fmb)-  = foldFMB id fmb . foldMV [] n $ z-  where-     g k x a = f a k x--     foldMV _ Nothing  = id-     foldMV ks (Just v) = g ks v--     foldFMB _ E = id-     foldFMB kf (I _ k mv l (FMB' m) r)-       = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l--foldrWithKey' = foldrWithKey-foldlWithKey' = foldlWithKey--foldl :: (a -> b -> a) -> a -> FM t b -> a-foldl op z (FM n fmb)-  = foldFMB fmb . foldMV n $ z-  where-    foldMV Nothing  = id-    foldMV (Just v) = (flip op) v--    foldFMB E = id-    foldFMB (I _ _ v l (FMB' m) r)-      = foldFMB r . foldFMB m . foldMV v . foldFMB l----- FIXME, understand this code to strictify it-foldr' = foldr-foldl' :: (a -> b -> a) -> a -> FM t b -> a-foldl' = foldl--foldr1 f fm =-  case maxView fm of-     Just (z,fm') -> foldr f z fm'-     Nothing      -> error $ moduleName++".foldr1: empty map"--foldl1 :: (b -> b -> b) -> FM k b -> b-foldl1 f fm =-  case minView fm of-     Just (z,fm') -> foldl f z fm'-     Nothing      -> error $ moduleName++".foldl1: empty map"---basecase :: Maybe t1 -> (t1 -> t) -> t -> t-basecase Nothing  = \_ n -> n-basecase (Just x) = \j _ -> j x--comb ::                                (t1 -> t1 -> t1)-                                    -> ((t1 -> t2) -> t2 -> t3)-                                    -> ((t1 -> t) -> t -> t2)-                                    -> (t1 -> t)-                                    -> t-                                    -> t3-comb f p1 p2-   = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n)--fold1 f (FM mv fmb)-  = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map")-  where-      fold1FMB E-        = \_ n -> n-      fold1FMB (I _ _ mv l (FMB' m) r)-        = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r)--fold1' = fold1--{--FIXME -- can these be somehow fixed to have the right order...--foldr1 f (FM v fmb)-  = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map")-  where-      fold1FMB E-        = \j n -> n-      fold1FMB (I _ _ v l (FMB' m) r)-        = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r)---foldl1 f (FM v fmb)-  = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map")-  where-      fold1FMB E-        = \j n -> n-      fold1FMB (I _ _ v l (FMB' m) r)-        = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l)--}------ FIXME, understand this code to strictify it-foldr1' = foldr1-foldl1' :: (b -> b -> b) -> FM k b -> b-foldl1' = foldl1---filter p = mapVFM (\mv -> case mv of-                            Nothing -> mv-                            Just v  -> if p v then mv else Nothing)--partition = partitionUsingFilter--elements = elementsUsingFold--strict z@(FM _ fmb) = strictFMB fmb `seq` z- where strictFMB n@E = n-       strictFMB n@(I _ _ _ l (FMB' m) r) =-           strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n--strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z-   where f' v@Nothing  = v-         f' v@(Just x) = f x `seq` v--         strictWithFMB n@E = n-         strictWithFMB n@(I _ _ v l (FMB' m) r) =-           f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n----- FiniteMapX--fromSeqWith = fromSeqWithUsingInsertSeqWith--fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey--insertWith f k v-  = addToFM k (\vem ->-      case vem of-          Nothing -> Just v-          Just ve -> Just (f ve v))--insertWithKey = insertWithKeyUsingInsertWith--insertSeqWith = insertSeqWithUsingInsertWith--insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey--unionl = union-unionr = flip union--unionWith f = unionWithKey (const f)--unionSeqWith = unionSeqWithUsingReduce--intersectionWith f = intersectionWithKey (const f)--difference mx my-  = mergeVFM (\v1 v2 -> case v2 of-              Nothing -> v1-              Just _  -> Nothing) mx my--properSubset = properSubsetUsingSubset--subset (FM nx fmbx) (FM ny fmby)-  = subsetEqM nx ny && subsetEqFMB fmbx fmby-  where-    subsetEqM Nothing _ = True-    subsetEqM (Just _) Nothing = False-    subsetEqM (Just _) (Just _) = True--    subsetEqFMB E _ = True-    subsetEqFMB fmbx@(I _ _ _ _ _ _) E-      = nullFMB fmbx-    subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx)-            fmby@(I sizey ky vy ly (FMB' my) ry)-      | sizex >= sizey-        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby-          in    subsetEqM vx vy-             && subsetEqFMB lx ly-             && subsetEqFMB mx my-             && subsetEqFMB rx ry-      | otherwise-        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx-          in    subsetEqM vx vy-             && subsetEqFMB lx ly-             && subsetEqFMB mx my-             && subsetEqFMB rx ry---submapBy = submapByUsingLookupM-properSubmapBy = properSubmapByUsingSubmapBy-sameMapBy = sameMapByUsingSubmapBy-properSubmap = A.properSubmap-submap = A.submap-sameMap = A.sameMap---- Assoc--toSeq = toSeqUsingFoldWithKey--keys = keysUsingFoldWithKey--mapWithKey f-  = mapKVFM (\k mv -> case mv of-          Nothing -> Nothing-          Just v  -> Just (f k v))--foldWithKey op r (FM n fmb)-  = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r-  where-      foldWithKeyB _ Nothing = id-      foldWithKeyB k (Just v) = op k v--      foldWithKeyFM _ E = id-      foldWithKeyFM ks (I _ k v l (FMB' m) r)-        = foldWithKeyFM ks l-        . foldWithKeyB (reverse (k:ks)) v-        . foldWithKeyFM (k:ks) m-        . foldWithKeyFM ks r----- FIXME, make this strict-foldWithKey' = foldWithKey---filterWithKey f-  = mapKVFM (\k mv -> case mv of-          Nothing -> mv-          Just v  -> if f k v then mv else Nothing)--partitionWithKey f m-  = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m)---- FiniteMap--unionWithKey f-  = mergeKVFM (\k v1m v2m ->-    case v1m of-        Nothing -> v2m-        Just v1 ->-            case v2m of-            Nothing -> v1m-            Just v2 -> Just (f k v1 v2))--unionSeqWithKey = unionSeqWithKeyUsingReduce--intersectionWithKey f-  = mergeKVFM (\k v1m v2m ->-    case v1m of-        Nothing -> Nothing-        Just v1 ->-            case v2m of-            Nothing -> Nothing-            Just v2 -> Just (f k v1 v2))---- OrdAssocX--minViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)-minViewFMB E _ = fail $ moduleName++".minView: empty map"-minViewFMB (I i k (Just v) E m r)        f = return (v, f (I i k Nothing E m r))-minViewFMB (I _ _ Nothing  E (FMB' E) _) _ = error $ moduleName++".minView: bug!"-minViewFMB (I _ k Nothing  E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))-minViewFMB (I _ k mv l m r)              f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r))--minView :: Fail.MonadFail m => FM k a -> m (a,FM k a)-minView (FM (Just v) fmb) = return (v, FM Nothing fmb)-minView (FM Nothing fmb)  = minViewFMB fmb (FM Nothing)--minViewWithKeyFMB :: Fail.MonadFail m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)-minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map"-minViewWithKeyFMB (I i k (Just v) E m r)        kf f = return ((kf [k],v),f (I i k Nothing E m r))-minViewWithKeyFMB (I _ _ Nothing  E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!"-minViewWithKeyFMB (I _ k Nothing  E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:))-                                                        (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))-minViewWithKeyFMB (I _ k mv l m r)              kf f = minViewWithKeyFMB l kf-                                                        (\l' -> f (mkVBalancedFMB k mv l' m r))--minViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a),FM k a)-minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb)-minViewWithKey (FM Nothing fmb)  = minViewWithKeyFMB fmb id (FM Nothing)---minElemFMB :: FMB k a -> a-minElemFMB E = error $ moduleName++".minElem: empty map"-minElemFMB (I _ _ (Just v) E _ _)        = v-minElemFMB (I _ _ Nothing  E (FMB' m) _) = minElemFMB m-minElemFMB (I _ _ _ l _ _)              = minElemFMB l--minElem :: FM t1 t -> t-minElem (FM (Just v) _) = v-minElem (FM Nothing  fmb) = minElemFMB fmb---minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a)-minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map"-minElemWithKeyFMB kf (I _ k (Just v) E _ _)        = (kf [k],v)-minElemWithKeyFMB kf (I _ k Nothing  E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m-minElemWithKeyFMB kf (I _ _ _ l _ _)              = minElemWithKeyFMB kf l--minElemWithKey :: FM k a -> ([k],a)-minElemWithKey (FM (Just v) _) = ([],v)-minElemWithKey (FM Nothing  fmb) = minElemWithKeyFMB id fmb--deleteMin :: Ord k => FM k a -> FM k a-deleteMin = deleteMinUsingMinView--unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a-unsafeInsertMin = insert--maxViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)-maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l)---maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E))-maxViewFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!"-maxViewFMB (I i k mv l (FMB' m) E)       f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E))-maxViewFMB (I _ k mv l m r)              f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r'))-maxViewFMB E                             _ = error $ moduleName++".maxView: bug!"--maxView :: Fail.MonadFail m => FM k a -> m (a, FM k a)-maxView (FM Nothing E)  = fail $ moduleName++".maxView: empty map"-maxView (FM (Just v) E) = return (v,FM Nothing E)-maxView (FM mv fmb)     = maxViewFMB fmb (FM mv)---maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)-maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l)-maxViewWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!"-maxViewWithKeyFMB (I i k mv l (FMB' m) E)       kf f = maxViewWithKeyFMB m (kf . (k:))-                                                        (\m' -> f (I i k mv l (FMB' m') E))-maxViewWithKeyFMB (I _ k mv l m r)              kf f = maxViewWithKeyFMB r kf-                                                        (\r' -> f (mkVBalancedFMB k mv l m r'))-maxViewWithKeyFMB E                             _ _ = error $ moduleName++".maxViewWithKey: bug!"---maxViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a), FM k a)-maxViewWithKey (FM Nothing E)  = fail $ moduleName++".maxViewWithKey: empty map"-maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E)-maxViewWithKey (FM mv fmb)     = maxViewWithKeyFMB fmb id (FM mv)----maxElemFMB :: FMB k a -> a-maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v-maxElemFMB (I _ _ Nothing  _ (FMB' E) E) = error $ moduleName++".maxElem: bug!"-maxElemFMB (I _ _ _ _ (FMB' m) E)       = maxElemFMB m-maxElemFMB (I _ _ _ _ _ r)              = maxElemFMB r-maxElemFMB E                             = error $ moduleName++".maxElem: bug!"--maxElem :: FM k a -> a-maxElem (FM (Just v) E) = v-maxElem (FM Nothing  E) = error $ moduleName++".maxElem: empty map"-maxElem (FM _ fmb)      = maxElemFMB fmb--maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a)-maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v)-maxElemWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!"-maxElemWithKeyFMB (I _ k _ _ (FMB' m) E)       kf = maxElemWithKeyFMB m (kf . (k:))-maxElemWithKeyFMB (I _ _ _ _ _ r)              kf = maxElemWithKeyFMB r kf-maxElemWithKeyFMB E                             _ = error $ moduleName++".maxElemWithKey: bug!"---maxElemWithKey :: FM k a -> ([k],a)-maxElemWithKey (FM (Just v) E) = ([],v)-maxElemWithKey (FM Nothing E)  = error $ moduleName++".maxElemWithKey: empty map"-maxElemWithKey (FM _ fmb)      = maxElemWithKeyFMB fmb id---deleteMax :: Ord k => FM k a -> FM k a-deleteMax = deleteMaxUsingMaxView--unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a-unsafeInsertMax = insert--unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a-unsafeFromOrdSeq = fromSeq--unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a-unsafeAppend = union---- FIXME this doesn't respect the structural invariant... why??-{--unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2)-unsafeAppend (FM Nothing  fmb1) (FM mv fmb2)      = FM mv       (appendFMB fmb1 fmb2)-unsafeAppend (FM (Just _) _) (FM (Just _) _)      = error $ moduleName++".unsafeAppend: bug!"--}--filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a-filterL_FMB _ _ _ E = E-filterL_FMB f k ks (I _ key mv l (FMB' m) r)-    | key < k   = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r)-    | key > k   = filterL_FMB f k ks l-    | otherwise = case ks of-                    []       -> f k mv l-                    (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E--filterLT :: Ord k => [k] -> FM k a -> FM k a-filterLT [] _               = FM Nothing E-filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb)--filterLE :: Ord k => [k] -> FM k a -> FM k a-filterLE [] (FM mv _)       = FM mv E-filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb)----filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a-filterG_FMB _ _ _ E = E-filterG_FMB f k ks (I _ key mv l (FMB' m) r)-    | key < k   = filterG_FMB f k ks r-    | key > k   = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r-    | otherwise = case ks of-                    []       -> f k mv m r-                    (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r--filterGT :: Ord k => [k] -> FM k a -> FM k a-filterGT []     (FM _  fmb) = FM Nothing fmb-filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb)--filterGE :: Ord k => [k] -> FM k a -> FM k a-filterGE []     fm          = fm-filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb)----FIXME do better...-partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm)--partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm)--partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm)--toOrdSeq = toOrdSeqUsingFoldrWithKey---- instance declarations--instance Ord k  => A.AssocX (FM k) [k] where-  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; union = union; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;-   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;-   lookupAndDeleteAll = lookupAndDeleteAll;-   lookupWithDefault = lookupWithDefault; adjust = adjust;-   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;-   adjustAllOrInsert = adjustAllOrInsert;-   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; elements = elements;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k  => A.Assoc (FM k) [k] where-  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;-   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';-   filterWithKey = filterWithKey;-   partitionWithKey = partitionWithKey}--instance Ord k => A.FiniteMapX (FM k) [k] where-  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;-   insertWith  = insertWith; insertWithKey = insertWithKey;-   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;-   unionl = unionl; unionr = unionr; unionWith = unionWith;-   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;-   difference = difference; properSubset = properSubset; subset = subset;-   properSubmapBy = properSubmapBy; submapBy = submapBy;-   sameMapBy = sameMapBy}--instance Ord k => A.FiniteMap (FM k) [k] where-  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;-   intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdAssocX (FM k) [k] where-  {minView = minView; minElem = minElem; deleteMin = deleteMin;-   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;-   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE;  partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord k => A.OrdAssoc (FM k) [k] where-  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;-   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;-   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';-   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';-   toOrdSeq = toOrdSeq}--instance Ord k => A.OrdFiniteMapX (FM k) [k]-instance Ord k => A.OrdFiniteMap (FM k) [k]---instance Ord k => Functor (FM k) where-  fmap = map--instance (Ord k, Show k, Show a) => Show (FM k a) where-  showsPrec = showsPrecUsingToList--instance (Ord k, Read k, Read a) => Read (FM k a) where-  readsPrec = readsPrecUsingFromList--instance (Ord k, Eq a) => Eq (FM k a) where-  (==) = sameMap--instance (Ord k, Ord a) => Ord (FM k a) where-  compare = compareUsingToOrdList------- Test code follows-----keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool-keyInvariantFMB _ E = True-keyInvariantFMB p (I _ k _ l _ r)-  =    p k-    && keyInvariantFMB p l-    && keyInvariantFMB p r--actualSizeFMB :: FMB k a -> Int-actualSizeFMB E = 0-actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r--structuralInvariantFMB :: Ord k => FMB k a -> Bool-structuralInvariantFMB E = True-structuralInvariantFMB fmb@(I size k _ l (FMB' m) r)-  =    structuralInvariantFMB l-    && structuralInvariantFMB m-    && structuralInvariantFMB r-    && keyInvariantFMB (<k) l-    && keyInvariantFMB (>k) r-    && actualSizeFMB fmb == size-    && (sizel + sizer < 2-        || (sizel <= balance * sizer && sizer <= balance * sizel))-  where-      sizel = sizeFMB l-      sizer = sizeFMB r--structuralInvariant :: Ord k => FM k a -> Bool-structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb---instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where-  arbitrary = do (xs::[([k],a)]) <- arbitrary-                 return (Prelude.foldr (uncurry insert) empty xs)--instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where-  coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb---coarbitrary_maybe :: (CoArbitrary t) => Maybe t  -> Test.QuickCheck.Gen b-                                                 -> Test.QuickCheck.Gen b-coarbitrary_maybe Nothing = variant 0-coarbitrary_maybe (Just x) = variant 1 . coarbitrary x--coarbitrary_fmb :: (CoArbitrary t1, CoArbitrary t) => FMB t t1 -> Gen a -> Gen a-coarbitrary_fmb E = variant 0-coarbitrary_fmb (I _ k x l (FMB' m) r) =-        variant 1 . coarbitrary k . coarbitrary_maybe x .-        coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r--instance Ord k => Semigroup (FM k a) where-   (<>) = union-instance Ord k => Monoid (FM k a) where-   mempty  = empty-   mappend = (SG.<>)-   mconcat = unionSeq-+-- |
+--   Module      :  Data.Edison.Assoc.TernaryTrie
+--   Copyright   :  Copyright (c) 2002, 2008 Andrew Bromage
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Finite maps indexed by lists or strings @[k]@, implemented as ternary
+--   search tries
+
+module Data.Edison.Assoc.TernaryTrie (
+    -- * Type of ternary search tries
+    FM,
+
+    -- * AssocX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,
+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,
+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,
+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,
+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,
+
+    -- * Assoc operations
+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,
+
+    -- * FiniteMapX operations
+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,
+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,
+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,
+    properSubmap,submap,sameMap,
+
+    -- * FiniteMap operations
+    unionWithKey,unionSeqWithKey,intersectionWithKey,
+
+    -- * OrdAssocX operations
+    minView, minElem, deleteMin, unsafeInsertMin,
+    maxView, maxElem, deleteMax, unsafeInsertMax,
+    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',
+    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,
+    partitionLT_GE, partitionLE_GT, partitionLT_GT,
+
+    -- * OrdAssoc operations
+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,
+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',
+    toOrdSeq,
+
+    -- * Other supported operations
+    mergeVFM, mergeKVFM,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
+import qualified Prelude
+import qualified Data.Edison.Assoc as A
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S
+import qualified Data.List as L
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Coerce (coerce)
+import Data.Monoid
+import Data.Semigroup as SG
+import Data.Maybe (isJust, isNothing)
+
+import Data.Edison.Assoc.Defaults
+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), NonNegative(..), variant, sized, resize, choose, oneof)
+
+
+-- signatures for exported functions
+moduleName    :: String
+empty         :: Ord k => FM k a
+singleton     :: Ord k => [k] -> a -> FM k a
+fromSeq       :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a
+insert        :: Ord k => [k] -> a -> FM k a -> FM k a
+insertSeq     :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a
+union         :: Ord k => FM k a -> FM k a -> FM k a
+unionSeq      :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a
+delete        :: Ord k => [k] -> FM k a -> FM k a
+deleteAll     :: Ord k => [k] -> FM k a -> FM k a
+deleteSeq     :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a
+null          :: Ord k => FM k a -> Bool
+size          :: Ord k => FM k a -> Int
+member        :: Ord k => [k] -> FM k a -> Bool
+count         :: Ord k => [k] -> FM k a -> Int
+lookup        :: Ord k => [k] -> FM k a -> a
+lookupM       :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm a
+lookupAll     :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a
+lookupAndDelete    :: Ord k => [k] -> FM k a -> (a, FM k a)
+lookupAndDeleteM   :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm (a, FM k a)
+lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a)
+lookupWithDefault  :: Ord k => a -> [k] -> FM k a -> a
+adjust        :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a
+adjustAll     :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a
+adjustOrInsert    :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a
+adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a
+adjustOrDelete    :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a
+adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a
+strict            :: FM k a -> FM k a
+strictWith        :: (a -> b) -> FM k a -> FM k a
+map           :: Ord k => (a -> b) -> FM k a -> FM k b
+fold          :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+fold1         :: Ord k => (a -> a -> a) -> FM k a -> a
+fold'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+fold1'        :: Ord k => (a -> a -> a) -> FM k a -> a
+filter        :: Ord k => (a -> Bool) -> FM k a -> FM k a
+partition     :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a)
+elements      :: (Ord k,S.Sequence seq) => FM k a -> seq a
+
+fromSeqWith      :: (Ord k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq ([k],a) -> FM k a
+fromSeqWithKey   :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a
+insertWith       :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a
+insertWithKey    :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a
+insertSeqWith    :: (Ord k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a
+insertSeqWithKey :: (Ord k,S.Sequence seq) =>
+                        ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a
+unionl           :: Ord k => FM k a -> FM k a -> FM k a
+unionr           :: Ord k => FM k a -> FM k a -> FM k a
+unionWith        :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWith     :: (Ord k,S.Sequence seq) =>
+                        (a -> a -> a) -> seq (FM k a) -> FM k a
+intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c
+difference       :: Ord k => FM k a -> FM k b -> FM k a
+properSubset     :: Ord k => FM k a -> FM k b -> Bool
+subset           :: Ord k => FM k a -> FM k b -> Bool
+properSubmapBy   :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+submapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+sameMapBy        :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
+properSubmap     :: (Ord k, Eq a) => FM k a -> FM k a -> Bool
+submap           :: (Ord k, Eq a) => FM k a -> FM k a -> Bool
+sameMap          :: (Ord k, Eq a) => FM k a -> FM k a -> Bool
+
+toSeq            :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)
+keys             :: (Ord k,S.Sequence seq) => FM k a -> seq [k]
+mapWithKey       :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b
+foldWithKey      :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
+foldWithKey'     :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
+filterWithKey    :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a
+partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a)
+unionWithKey     :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a
+unionSeqWithKey  :: (Ord k,S.Sequence seq) =>
+                       ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a
+intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c
+
+foldr          :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldr1         :: Ord k => (a -> a -> a) -> FM k a -> a
+foldr'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b
+foldr1'        :: Ord k => (a -> a -> a) -> FM k a -> a
+
+foldrWithKey   :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
+foldrWithKey'  :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
+foldlWithKey   :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b
+foldlWithKey'  :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b
+toOrdSeq       :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)
+
+moduleName = "Data.Edison.Assoc.TernaryTrie"
+
+
+data FM k a
+  = FM !(Maybe a) !(FMB k a)
+
+-- | This is isomorphic to an iteration of binary trees with keys @k@.
+--
+-- @
+-- data BT k v = E | I k v (BT k v) (BT k v)
+-- data Layer k v x = Layer (Maybe v) (BT k x)
+--
+-- FMB k v = Fix (Layer k v)
+-- @
+--
+-- The trees are weight-balanced trees, ensuring that the sizes of the
+-- two subtrees of any node are bounded by each other up to a constant factor.
+--
+-- @
+-- size l + size r <= 1
+--
+-- -- or --
+--
+-- size l <= 6 * size r
+-- size r <= 6 * size l
+-- @
+--
+-- Source: <https://yoichihirai.com/bst.pdf Balancing Weight-Balanced Trees>
+-- by Hirai and Yamamoto, 2011 (Section 4)
+data FMB k v
+  = E
+  | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v)
+  deriving Show
+
+newtype FMB' k v
+  = FMB' (FMB k v)
+  deriving Show
+
+-- | The balance factor must be either 3 or 4.
+-- With other factors, the invariant gets broken by delete, minViewWithKey and maxViewWithKey.
+-- (cf. Section 4 of the paper linked above)
+balance :: Int
+balance = 4
+
+sizeFMB :: FMB k v -> Int
+sizeFMB E = 0
+sizeFMB (I size _ _ _ _ _) = size
+
+mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
+mkFMB k v l m r
+  = I (1 + sizeFMB l + sizeFMB r) k v l m r
+
+lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v
+lookupFMB []        _
+  = Nothing
+lookupFMB (_:_) E
+  = Nothing
+lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r)
+  = case compare x k of
+        LT -> lookupFMB nk l
+        GT -> lookupFMB nk r
+        EQ -> if L.null xs then v else lookupFMB xs fmbm
+
+listToFMB :: [k] -> v -> FMB k v
+listToFMB [x]    v = mkFMB x (Just v) E (FMB' E)                E
+listToFMB (x:xs) v = mkFMB x Nothing  E (FMB' $ listToFMB xs v) E
+listToFMB _ _ = error "TernaryTrie.listToFMB: bug!"
+
+addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v
+addToFMB xs combiner E
+  = case combiner Nothing of
+      Just v -> listToFMB xs v
+      Nothing -> E
+addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r)
+  = case compare x k of
+        LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r
+        GT -> mkBalancedFMB k v l m (addToFMB nk combiner r)
+        EQ -> case xs of
+                [] -> case combiner v of
+                  Nothing | FMB' E <- m -> appendFMB l r
+                  v' -> I size k v' l m r
+                _  -> case addToFMB xs combiner fmbm of
+                  E | Nothing <- v -> appendFMB l r
+                  m' -> I size k v l (FMB' m') r
+addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!"
+
+addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v
+addToFM [] combiner (FM n fmb)
+  = FM (combiner n) fmb
+addToFM xs combiner (FM n fmb)
+  = FM n (addToFMB xs combiner fmb)
+
+lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z
+lookupAndDelFromFMB onFail _ _ E = onFail
+lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r)
+  = case compare x k of
+        LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l
+        GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r
+        EQ -> case xs of
+                [] -> case v of
+                        Nothing -> onFail
+                        Just w  -> case fmbm of
+                                      E -> cont w (appendFMB l r)
+                                      _ -> cont w (I size k Nothing l m r)
+                _  -> lookupAndDelFromFMB onFail (\w m' -> case m' of
+                  E | Nothing <- v -> cont w (appendFMB l r)
+                  _ -> cont w (I size k v l (FMB' m') r)) xs fmbm
+lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!"
+
+lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z
+lookupAndDelFromFM onFail _ [] (FM Nothing _)  = onFail
+lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb)
+lookupAndDelFromFM onFail cont xs (FM n fmb) =
+   lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb
+
+
+delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v
+delFromFMB _ E
+  = E
+delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r)
+  = case compare x k of
+        LT -> mkBalancedFMB k v (delFromFMB nk l) m r
+        GT -> mkBalancedFMB k v l m (delFromFMB nk r)
+        EQ -> case xs of
+                [] -> case fmbm of
+                        E -> appendFMB l r
+                        _ -> I size k Nothing l m r
+                _  -> case delFromFMB xs fmbm of
+                  E | Nothing <- v -> appendFMB l r
+                  m' -> I size k v l (FMB' m') r
+delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!"
+
+
+delFromFM :: (Ord k) => [k] -> FM k v -> FM k v
+delFromFM [] (FM _ fmb)
+  = FM Nothing fmb
+delFromFM xs (FM n fmb)
+  = FM n (delFromFMB xs fmb)
+
+
+mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
+mkBalancedFMB k v l m r
+  | size_l + size_r < 2
+    = mkFMB k v l m r
+  | size_r > balance * size_l        -- Right tree too big
+    = case r of
+        I _ _ _ rl _ rr
+            | sizeFMB rl < 2 * sizeFMB rr
+                -> single_L l m r
+            | otherwise
+                -> double_L l m r
+        _ -> error "TernaryTrie.mkBalancedFMB: bug!"
+
+  | size_l > balance * size_r   -- Left tree too big
+    = case l of
+        I _ _ _ ll _ lr
+            | sizeFMB lr < 2 * sizeFMB ll
+                -> single_R l m r
+            | otherwise
+                -> double_R l m r
+        _ -> error "TernaryTrie.mkBalancedFMB: bug!"
+
+  | otherwise                           -- No imbalance
+    = mkFMB k v l m r
+  where
+        size_l   = sizeFMB l
+        size_r   = sizeFMB r
+
+        single_L l m (I _ k_r v_r rl rm rr)
+          = mkFMB k_r v_r (mkFMB k v l m rl) rm rr
+        single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"
+
+        double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr)
+          = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr)
+        double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"
+
+        single_R (I _ k_l v_l ll lm lr) m r
+          = mkFMB k_l v_l ll lm (mkFMB k v lr m r)
+        single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"
+
+        double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r
+          = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r)
+        double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"
+
+
+mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
+mkVBalancedFMB k Nothing l (FMB' E) r
+  = appendFMB l r
+mkVBalancedFMB k v E m E
+  = mkFMB k v E m E
+mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr)
+  = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr
+mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E
+  = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)
+mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr)
+  | balance * size_l < size_r
+    = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr
+  | balance * size_r < size_l
+    = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)
+  | otherwise
+    = mkFMB k v l m r
+  where
+        size_l = sizeFMB l
+        size_r = sizeFMB r
+
+    -- Constraint: All keys in the first FMB are less than
+    -- that in the second FMB.
+appendFMB :: FMB k v -> FMB k v -> FMB k v
+appendFMB E m2 = m2
+appendFMB m1 E = m1
+appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2)
+  | size1 > size2
+    = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2)
+  | otherwise
+    = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2
+
+mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b
+mapVFM f (FM n fmb)
+  = FM (f n) (mapVFMB f fmb)
+
+mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b
+mapVFMB f m
+  = mapVFMB' m
+  where
+        mapVFMB' E = E
+        mapVFMB' (I _ k v l (FMB' m) r)
+          = case (mapVFMB' m, f v) of
+                (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r)
+                (m',v')     -> mkVBalancedFMB k v'
+                                    (mapVFMB' l) (FMB' m') (mapVFMB' r)
+
+mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b
+mapKVFM f (FM n fmb)
+  = FM (f [] n) (mapKVFMB [] fmb)
+  where
+        mapKVFMB _ E = E
+        mapKVFMB ks (I _ k v l (FMB' m) r)
+          = mkVBalancedFMB k (f (reverse (k:ks)) v)
+              (mapKVFMB ks l)
+              (FMB' (mapKVFMB (k:ks) m))
+              (mapKVFMB ks r)
+
+nullFMB :: FMB k v -> Bool
+nullFMB E = True
+nullFMB (I _ _ v l (FMB' m) r)
+  = case v of
+      Just _  -> False
+      Nothing -> nullFMB l && nullFMB m && nullFMB r
+
+nullFM :: FM k v -> Bool
+nullFM (FM (Just _) _)  = False
+nullFM (FM Nothing fmb) = nullFMB fmb
+
+data FMBCtx k v
+  = T
+  | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v)
+  | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v)
+
+splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a)
+splayFMB key fmb
+  = splaydown T fmb
+  where
+    splaydown ctx E
+      = splayup ctx Nothing E (FMB' E) E
+    splaydown ctx (I _ k v l m r)
+      = case compare key k of
+            LT -> splaydown (L k v ctx m r) l
+            GT -> splaydown (R k v l m ctx) r
+            EQ -> splayup ctx v l m r
+
+    splayup ctx v l m r
+      = splayup' ctx l r
+      where
+          splayup' T l r
+            = (v, l, m, r)
+          splayup' (L ck cv ctx cm cr) tl tr
+            = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr)
+          splayup' (R ck cv cl cm ctx) tl tr
+            = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr
+
+mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->
+                FMB k a -> FMB k b -> FMB k c
+mergeVFMB f fmbx fmby
+  = mergeVFMB' fmbx fmby
+  where
+    mergeVFMB' E E
+      = E
+    mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _)
+      = mapVFMB (\v -> f Nothing v) fmby
+    mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E
+      = mapVFMB (\v -> f v Nothing) fmbx
+    mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx)
+               fmby@(I sizey ky vy ly (FMB' my) ry)
+      | sizex >= sizey
+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
+          in case (mergeVFMB' mx my, f vx vy) of
+                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)
+                (m',v)      -> mkVBalancedFMB kx v
+                                   (mergeVFMB' lx ly)
+                                   (FMB' m')
+                                   (mergeVFMB' rx ry)
+      | otherwise
+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
+          in case (mergeVFMB' mx my, f vx vy) of
+                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)
+                (m',v)      -> mkVBalancedFMB ky v
+                                   (mergeVFMB' lx ly)
+                                   (FMB' m')
+                                   (mergeVFMB' rx ry)
+
+mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->
+                FM k a -> FM k b -> FM k c
+mergeVFM f (FM vx fmbx) (FM vy fmby)
+  = FM (f vx vy) (mergeVFMB f fmbx fmby)
+
+
+mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->
+                FMB k a -> FMB k b -> FMB k c
+mergeKVFMB f fmbx fmby
+  = mergeKVFMB' [] fmbx fmby
+  where
+    mergeKVFMB' _ E E
+      = E
+    mergeKVFMB' ks E fmby
+      = mergeKVFMBs (\k v -> f k Nothing v) ks fmby
+    mergeKVFMB' ks fmbx E
+      = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx
+    mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx)
+                   fmby@(I sizey ky vy ly (FMB' my) ry)
+      | sizex >= sizey
+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
+              ks' = reverse (kx:ks)
+          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of
+                (E,Nothing) -> appendFMB
+                                    (mergeKVFMB' ks lx ly)
+                                    (mergeKVFMB' ks rx ry)
+                (m',v)      -> mkVBalancedFMB kx v
+                                    (mergeKVFMB' ks lx ly)
+                                    (FMB' m')
+                                    (mergeKVFMB' ks rx ry)
+      | otherwise
+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
+              ks' = reverse (ky:ks)
+          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of
+                (E,Nothing) -> appendFMB
+                                    (mergeKVFMB' ks lx ly)
+                                    (mergeKVFMB' ks rx ry)
+                (m',v)      -> mkVBalancedFMB ky v
+                                    (mergeKVFMB' ks lx ly)
+                                    (FMB' m')
+                                    (mergeKVFMB' ks rx ry)
+
+    mergeKVFMBs f ks fmb
+      = mergeKVFMBs' ks fmb
+      where
+          mergeKVFMBs' _ E
+            = E
+          mergeKVFMBs' ks (I _ k v l (FMB' m) r)
+            = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of
+                (E, Nothing) -> appendFMB
+                                    (mergeKVFMBs' ks l)
+                                    (mergeKVFMBs' ks r)
+                (m,v)        -> mkVBalancedFMB k v
+                                    (mergeKVFMBs' ks l)
+                                    (FMB' m)
+                                    (mergeKVFMBs' ks r)
+
+mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->
+                FM k a -> FM k b -> FM k c
+mergeKVFM f (FM vx fmbx) (FM vy fmby)
+  = FM (f [] vx vy) (mergeKVFMB f fmbx fmby)
+
+
+-- The public interface.
+--
+
+-- AssocX
+
+empty = FM Nothing E
+
+singleton [] v = FM (Just v) E
+singleton xs v = FM Nothing (listToFMB xs v)
+
+fromSeq = fromSeqUsingInsertSeq
+
+insert k v fm = addToFM k (\_ -> Just v) fm
+
+insertSeq = insertSeqUsingFoldr
+
+union = mergeVFM mplus
+
+unionSeq = unionSeqUsingReduce
+
+delete k fm = delFromFM k fm
+
+deleteAll = delete
+
+deleteSeq = deleteSeqUsingFoldr
+
+null = nullFM
+
+size (FM k fmb)
+    | isNothing k = fmb_size fmb 0
+    | otherwise   = fmb_size fmb 1
+    where fmb_size E k = k
+          fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k
+          fmb_size (I _ _ _ l (FMB' m) r ) k      = fmb_size l $ fmb_size m $ fmb_size r $! k+1
+
+
+member = memberUsingLookupM
+
+count = countUsingMember
+
+lookup m k = runFail_ (lookupM m k)
+
+lookupM [] (FM Nothing _)
+  = fail "TernaryTrie.lookup: lookup failed"
+lookupM [] (FM (Just v) _)
+  = return v
+lookupM xs (FM _ fmb)
+  = case  lookupFMB xs fmb  of
+        Nothing -> fail "TernaryTrie.lookup: lookup failed"
+        Just v  -> return v
+
+lookupAll = lookupAllUsingLookupM
+
+lookupAndDelete =
+    lookupAndDelFromFM
+      (error "TernaryTrie.lookupAndDelete: lookup failed")
+      (,)
+
+lookupAndDeleteM =
+    lookupAndDelFromFM
+      (fail  "TernaryTrie.lookupAndDeleteM: lookup failed")
+      (\w m -> return (w,m))
+
+lookupAndDeleteAll k m =
+    lookupAndDelFromFM
+      (S.empty,m)
+      (\w m' -> (S.singleton w,m'))
+      k m
+
+lookupWithDefault = lookupWithDefaultUsingLookupM
+
+adjust f k
+  = addToFM k (\mv -> case mv of
+                        Nothing -> mv
+                        Just v  -> Just (f v))
+
+adjustAll = adjust
+
+adjustOrInsert f z k
+  = addToFM k (\mv -> case mv of
+                        Nothing -> Just z
+                        Just v  -> Just (f v))
+
+adjustAllOrInsert = adjustOrInsert
+
+adjustOrDelete f k
+  = addToFM k (\mv -> case mv of
+                        Nothing -> mv
+                        Just v  -> f v)
+
+adjustOrDeleteAll = adjustOrDelete
+
+map f
+  = mapVFM (\mv -> case mv of
+                        Nothing -> Nothing
+                        Just v  -> Just (f v))
+
+fold = foldr
+fold' = foldr'
+
+foldr op z (FM n fmb)
+  = foldMV n . foldFMB fmb $ z
+  where
+    foldMV Nothing  = id
+    foldMV (Just v) = op v
+
+    foldFMB E
+      = id
+    foldFMB (I _ _ v l (FMB' m) r)
+      = foldFMB l . foldMV v . foldFMB m . foldFMB r
+
+foldrWithKey f z (FM n fmb)
+  = foldMV [] n . foldFMB id fmb $ z
+  where
+     foldMV _ Nothing  = id
+     foldMV ks (Just v) = f ks v
+
+     foldFMB _ E = id
+     foldFMB kf (I _ k mv l (FMB' m) r)
+       = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r
+
+foldlWithKey f z (FM n fmb)
+  = foldFMB id fmb . foldMV [] n $ z
+  where
+     g k x a = f a k x
+
+     foldMV _ Nothing  = id
+     foldMV ks (Just v) = g ks v
+
+     foldFMB _ E = id
+     foldFMB kf (I _ k mv l (FMB' m) r)
+       = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l
+
+foldrWithKey' = foldrWithKey
+foldlWithKey' = foldlWithKey
+
+foldl :: (a -> b -> a) -> a -> FM t b -> a
+foldl op z (FM n fmb)
+  = foldFMB fmb . foldMV n $ z
+  where
+    foldMV Nothing  = id
+    foldMV (Just v) = (flip op) v
+
+    foldFMB E = id
+    foldFMB (I _ _ v l (FMB' m) r)
+      = foldFMB r . foldFMB m . foldMV v . foldFMB l
+
+
+-- FIXME, understand this code to strictify it
+foldr' = foldr
+foldl' :: (a -> b -> a) -> a -> FM t b -> a
+foldl' = foldl
+
+foldr1 f fm =
+  case maxView fm of
+     Just (z,fm') -> foldr f z fm'
+     Nothing      -> error $ moduleName++".foldr1: empty map"
+
+foldl1 :: (b -> b -> b) -> FM k b -> b
+foldl1 f fm =
+  case minView fm of
+     Just (z,fm') -> foldl f z fm'
+     Nothing      -> error $ moduleName++".foldl1: empty map"
+
+
+basecase :: Maybe t1 -> (t1 -> t) -> t -> t
+basecase Nothing  = \_ n -> n
+basecase (Just x) = \j _ -> j x
+
+comb ::                                (t1 -> t1 -> t1)
+                                    -> ((t1 -> t2) -> t2 -> t3)
+                                    -> ((t1 -> t) -> t -> t2)
+                                    -> (t1 -> t)
+                                    -> t
+                                    -> t3
+comb f p1 p2
+   = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n)
+
+fold1 f (FM mv fmb)
+  = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map")
+  where
+      fold1FMB E
+        = \_ n -> n
+      fold1FMB (I _ _ mv l (FMB' m) r)
+        = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r)
+
+fold1' = fold1
+
+{-
+FIXME -- can these be somehow fixed to have the right order...
+
+foldr1 f (FM v fmb)
+  = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map")
+  where
+      fold1FMB E
+        = \j n -> n
+      fold1FMB (I _ _ v l (FMB' m) r)
+        = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r)
+
+
+foldl1 f (FM v fmb)
+  = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map")
+  where
+      fold1FMB E
+        = \j n -> n
+      fold1FMB (I _ _ v l (FMB' m) r)
+        = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l)
+-}
+
+
+
+-- FIXME, understand this code to strictify it
+foldr1' = foldr1
+foldl1' :: (b -> b -> b) -> FM k b -> b
+foldl1' = foldl1
+
+
+filter p = mapVFM (\mv -> case mv of
+                            Nothing -> mv
+                            Just v  -> if p v then mv else Nothing)
+
+partition = partitionUsingFilter
+
+elements = elementsUsingFold
+
+strict z@(FM _ fmb) = strictFMB fmb `seq` z
+ where strictFMB n@E = n
+       strictFMB n@(I _ _ _ l (FMB' m) r) =
+           strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n
+
+strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z
+   where f' v@Nothing  = v
+         f' v@(Just x) = f x `seq` v
+
+         strictWithFMB n@E = n
+         strictWithFMB n@(I _ _ v l (FMB' m) r) =
+           f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n
+
+
+-- FiniteMapX
+
+fromSeqWith = fromSeqWithUsingInsertSeqWith
+
+fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey
+
+insertWith f k v
+  = addToFM k (\vem ->
+      case vem of
+          Nothing -> Just v
+          Just ve -> Just (f ve v))
+
+insertWithKey = insertWithKeyUsingInsertWith
+
+insertSeqWith = insertSeqWithUsingInsertWith
+
+insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey
+
+unionl = union
+unionr = flip union
+
+unionWith f = unionWithKey (const f)
+
+unionSeqWith = unionSeqWithUsingReduce
+
+intersectionWith f = intersectionWithKey (const f)
+
+difference mx my
+  = mergeVFM (\v1 v2 -> case v2 of
+              Nothing -> v1
+              Just _  -> Nothing) mx my
+
+properSubset = properSubsetUsingSubset
+
+subset (FM nx fmbx) (FM ny fmby)
+  = subsetEqM nx ny && subsetEqFMB fmbx fmby
+  where
+    subsetEqM Nothing _ = True
+    subsetEqM (Just _) Nothing = False
+    subsetEqM (Just _) (Just _) = True
+
+    subsetEqFMB E _ = True
+    subsetEqFMB fmbx@(I _ _ _ _ _ _) E
+      = nullFMB fmbx
+    subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx)
+            fmby@(I sizey ky vy ly (FMB' my) ry)
+      | sizex >= sizey
+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
+          in    subsetEqM vx vy
+             && subsetEqFMB lx ly
+             && subsetEqFMB mx my
+             && subsetEqFMB rx ry
+      | otherwise
+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
+          in    subsetEqM vx vy
+             && subsetEqFMB lx ly
+             && subsetEqFMB mx my
+             && subsetEqFMB rx ry
+
+
+submapBy = submapByUsingLookupM
+properSubmapBy = properSubmapByUsingSubmapBy
+sameMapBy = sameMapByUsingSubmapBy
+properSubmap = A.properSubmap
+submap = A.submap
+sameMap = A.sameMap
+
+-- Assoc
+
+toSeq = toSeqUsingFoldWithKey
+
+keys = keysUsingFoldWithKey
+
+mapWithKey f
+  = mapKVFM (\k mv -> case mv of
+          Nothing -> Nothing
+          Just v  -> Just (f k v))
+
+foldWithKey op r (FM n fmb)
+  = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r
+  where
+      foldWithKeyB _ Nothing = id
+      foldWithKeyB k (Just v) = op k v
+
+      foldWithKeyFM _ E = id
+      foldWithKeyFM ks (I _ k v l (FMB' m) r)
+        = foldWithKeyFM ks l
+        . foldWithKeyB (reverse (k:ks)) v
+        . foldWithKeyFM (k:ks) m
+        . foldWithKeyFM ks r
+
+
+-- FIXME, make this strict
+foldWithKey' = foldWithKey
+
+
+filterWithKey f
+  = mapKVFM (\k mv -> case mv of
+          Nothing -> mv
+          Just v  -> if f k v then mv else Nothing)
+
+partitionWithKey f m
+  = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m)
+
+-- FiniteMap
+
+unionWithKey f
+  = mergeKVFM (\k v1m v2m ->
+    case v1m of
+        Nothing -> v2m
+        Just v1 ->
+            case v2m of
+            Nothing -> v1m
+            Just v2 -> Just (f k v1 v2))
+
+unionSeqWithKey = unionSeqWithKeyUsingReduce
+
+intersectionWithKey f
+  = mergeKVFM (\k v1m v2m ->
+    case v1m of
+        Nothing -> Nothing
+        Just v1 ->
+            case v2m of
+            Nothing -> Nothing
+            Just v2 -> Just (f k v1 v2))
+
+-- OrdAssocX
+
+minViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)
+minViewFMB E _ = fail $ moduleName++".minView: empty map"
+minViewFMB (I i k (Just v) E m r)        f = return (v, f t)
+  where
+    t = case m of
+      FMB' E -> r
+      _ -> I i k Nothing E m r
+minViewFMB (I _ _ Nothing  E (FMB' E) _) _ = error $ moduleName++".minView: bug!"
+minViewFMB (I _ k Nothing  E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))
+minViewFMB (I _ k mv l m r)              f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r))
+
+minView :: Fail.MonadFail m => FM k a -> m (a,FM k a)
+minView (FM (Just v) fmb) = return (v, FM Nothing fmb)
+minView (FM Nothing fmb)  = minViewFMB fmb (FM Nothing)
+
+minViewWithKeyFMB :: Fail.MonadFail m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)
+minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map"
+minViewWithKeyFMB (I i k (Just v) E m r)        kf f = return ((kf [k],v),f t)
+  where
+    t = case m of
+      FMB' E -> r
+      _ -> I i k Nothing E m r
+minViewWithKeyFMB (I _ _ Nothing  E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!"
+minViewWithKeyFMB (I _ k Nothing  E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:))
+                                                        (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))
+minViewWithKeyFMB (I _ k mv l m r)              kf f = minViewWithKeyFMB l kf
+                                                        (\l' -> f (mkVBalancedFMB k mv l' m r))
+
+minViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a),FM k a)
+minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb)
+minViewWithKey (FM Nothing fmb)  = minViewWithKeyFMB fmb id (FM Nothing)
+
+
+minElemFMB :: FMB k a -> a
+minElemFMB E = error $ moduleName++".minElem: empty map"
+minElemFMB (I _ _ (Just v) E _ _)        = v
+minElemFMB (I _ _ Nothing  E (FMB' m) _) = minElemFMB m
+minElemFMB (I _ _ _ l _ _)              = minElemFMB l
+
+minElem :: FM t1 t -> t
+minElem (FM (Just v) _) = v
+minElem (FM Nothing  fmb) = minElemFMB fmb
+
+
+minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a)
+minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map"
+minElemWithKeyFMB kf (I _ k (Just v) E _ _)        = (kf [k],v)
+minElemWithKeyFMB kf (I _ k Nothing  E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m
+minElemWithKeyFMB kf (I _ _ _ l _ _)              = minElemWithKeyFMB kf l
+
+minElemWithKey :: FM k a -> ([k],a)
+minElemWithKey (FM (Just v) _) = ([],v)
+minElemWithKey (FM Nothing  fmb) = minElemWithKeyFMB id fmb
+
+deleteMin :: Ord k => FM k a -> FM k a
+deleteMin = deleteMinUsingMinView
+
+unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a
+unsafeInsertMin = insert
+
+maxViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)
+maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l)
+--maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E))
+maxViewFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!"
+maxViewFMB (I i k mv l (FMB' m) E)       f = maxViewFMB m (\m' -> f (t m'))
+  where
+    t m' = case m' of
+      E | Nothing <- mv -> l
+      _ -> I i k mv l (FMB' m') E
+maxViewFMB (I _ k mv l m r)              f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r'))
+maxViewFMB E                             _ = error $ moduleName++".maxView: bug!"
+
+maxView :: Fail.MonadFail m => FM k a -> m (a, FM k a)
+maxView (FM Nothing E)  = fail $ moduleName++".maxView: empty map"
+maxView (FM (Just v) E) = return (v,FM Nothing E)
+maxView (FM mv fmb)     = maxViewFMB fmb (FM mv)
+
+
+maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)
+maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l)
+maxViewWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!"
+maxViewWithKeyFMB (I i k mv l (FMB' m) E)       kf f = maxViewWithKeyFMB m (kf . (k:))
+                                                        (\m' -> f (t m'))
+  where
+    t m' = case m' of
+      E | Nothing <- mv -> l
+      _ -> I i k mv l (FMB' m') E
+maxViewWithKeyFMB (I _ k mv l m r)              kf f = maxViewWithKeyFMB r kf
+                                                        (\r' -> f (mkVBalancedFMB k mv l m r'))
+maxViewWithKeyFMB E                             _ _ = error $ moduleName++".maxViewWithKey: bug!"
+
+
+maxViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a), FM k a)
+maxViewWithKey (FM Nothing E)  = fail $ moduleName++".maxViewWithKey: empty map"
+maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E)
+maxViewWithKey (FM mv fmb)     = maxViewWithKeyFMB fmb id (FM mv)
+
+
+
+maxElemFMB :: FMB k a -> a
+maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v
+maxElemFMB (I _ _ Nothing  _ (FMB' E) E) = error $ moduleName++".maxElem: bug!"
+maxElemFMB (I _ _ _ _ (FMB' m) E)       = maxElemFMB m
+maxElemFMB (I _ _ _ _ _ r)              = maxElemFMB r
+maxElemFMB E                             = error $ moduleName++".maxElem: bug!"
+
+maxElem :: FM k a -> a
+maxElem (FM (Just v) E) = v
+maxElem (FM Nothing  E) = error $ moduleName++".maxElem: empty map"
+maxElem (FM _ fmb)      = maxElemFMB fmb
+
+maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a)
+maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v)
+maxElemWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!"
+maxElemWithKeyFMB (I _ k _ _ (FMB' m) E)       kf = maxElemWithKeyFMB m (kf . (k:))
+maxElemWithKeyFMB (I _ _ _ _ _ r)              kf = maxElemWithKeyFMB r kf
+maxElemWithKeyFMB E                             _ = error $ moduleName++".maxElemWithKey: bug!"
+
+
+maxElemWithKey :: FM k a -> ([k],a)
+maxElemWithKey (FM (Just v) E) = ([],v)
+maxElemWithKey (FM Nothing E)  = error $ moduleName++".maxElemWithKey: empty map"
+maxElemWithKey (FM _ fmb)      = maxElemWithKeyFMB fmb id
+
+
+deleteMax :: Ord k => FM k a -> FM k a
+deleteMax = deleteMaxUsingMaxView
+
+unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a
+unsafeInsertMax = insert
+
+unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a
+unsafeFromOrdSeq = fromSeq
+
+unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a
+unsafeAppend = union
+
+-- FIXME this doesn't respect the structural invariant... why??
+{-
+unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2)
+unsafeAppend (FM Nothing  fmb1) (FM mv fmb2)      = FM mv       (appendFMB fmb1 fmb2)
+unsafeAppend (FM (Just _) _) (FM (Just _) _)      = error $ moduleName++".unsafeAppend: bug!"
+-}
+
+filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a
+filterL_FMB _ _ _ E = E
+filterL_FMB f k ks (I _ key mv l (FMB' m) r)
+    | key < k   = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r)
+    | key > k   = filterL_FMB f k ks l
+    | otherwise = case ks of
+                    []       -> f k mv l
+                    (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E
+
+filterLT :: Ord k => [k] -> FM k a -> FM k a
+filterLT [] _               = FM Nothing E
+filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb)
+
+filterLE :: Ord k => [k] -> FM k a -> FM k a
+filterLE [] (FM mv _)       = FM mv E
+filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb)
+
+
+
+filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a
+filterG_FMB _ _ _ E = E
+filterG_FMB f k ks (I _ key mv l (FMB' m) r)
+    | key < k   = filterG_FMB f k ks r
+    | key > k   = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r
+    | otherwise = case ks of
+                    []       -> f k mv m r
+                    (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r
+
+filterGT :: Ord k => [k] -> FM k a -> FM k a
+filterGT []     (FM _  fmb) = FM Nothing fmb
+filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb)
+
+filterGE :: Ord k => [k] -> FM k a -> FM k a
+filterGE []     fm          = fm
+filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb)
+
+--FIXME do better...
+partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
+partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm)
+
+partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
+partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm)
+
+partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
+partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm)
+
+toOrdSeq = toOrdSeqUsingFoldrWithKey
+
+-- instance declarations
+
+instance Ord k  => A.AssocX (FM k) [k] where
+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; union = union; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;
+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;
+   lookupAndDeleteAll = lookupAndDeleteAll;
+   lookupWithDefault = lookupWithDefault; adjust = adjust;
+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;
+   adjustAllOrInsert = adjustAllOrInsert;
+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; elements = elements;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord k  => A.Assoc (FM k) [k] where
+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;
+   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';
+   filterWithKey = filterWithKey;
+   partitionWithKey = partitionWithKey}
+
+instance Ord k => A.FiniteMapX (FM k) [k] where
+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;
+   insertWith  = insertWith; insertWithKey = insertWithKey;
+   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;
+   unionl = unionl; unionr = unionr; unionWith = unionWith;
+   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;
+   difference = difference; properSubset = properSubset; subset = subset;
+   properSubmapBy = properSubmapBy; submapBy = submapBy;
+   sameMapBy = sameMapBy}
+
+instance Ord k => A.FiniteMap (FM k) [k] where
+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;
+   intersectionWithKey = intersectionWithKey}
+
+instance Ord k => A.OrdAssocX (FM k) [k] where
+  {minView = minView; minElem = minElem; deleteMin = deleteMin;
+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;
+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE;  partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord k => A.OrdAssoc (FM k) [k] where
+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;
+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;
+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';
+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';
+   toOrdSeq = toOrdSeq}
+
+instance Ord k => A.OrdFiniteMapX (FM k) [k]
+instance Ord k => A.OrdFiniteMap (FM k) [k]
+
+
+instance Ord k => Functor (FM k) where
+  fmap = map
+
+instance (Ord k, Show k, Show a) => Show (FM k a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Ord k, Read k, Read a) => Read (FM k a) where
+  readsPrec = readsPrecUsingFromList
+
+instance (Ord k, Eq a) => Eq (FM k a) where
+  (==) = sameMap
+
+instance (Ord k, Ord a) => Ord (FM k a) where
+  compare = compareUsingToOrdList
+
+--
+-- Test code follows
+--
+
+keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool
+keyInvariantFMB _ E = True
+keyInvariantFMB p (I _ k _ l _ r)
+  =    p k
+    && keyInvariantFMB p l
+    && keyInvariantFMB p r
+
+actualSizeFMB :: FMB k a -> Int
+actualSizeFMB E = 0
+actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r
+
+structuralInvariantFMB :: Ord k => FMB k a -> Bool
+structuralInvariantFMB E = True
+structuralInvariantFMB fmb@(I size k v l (FMB' m) r)
+  =    structuralInvariantFMB l
+    && structuralInvariantFMB m
+    && structuralInvariantFMB r
+    && keyInvariantFMB (<k) l
+    && keyInvariantFMB (>k) r
+    && actualSizeFMB fmb == size
+    && isBalanced l r
+    && relevantRoot fmb
+
+isBalanced :: FMB k a -> FMB k a -> Bool
+isBalanced l r = sizel + sizer <= 1
+  || (sizel <= balance * sizer && sizer <= balance * sizel)
+  where
+      sizel = sizeFMB l
+      sizer = sizeFMB r
+
+-- | This invariant is used by minView
+relevantRoot :: FMB k a -> Bool
+relevantRoot (I _ _ Nothing _ (FMB' E) _) = False
+relevantRoot _ = True
+
+structuralInvariant :: Ord k => FM k a -> Bool
+structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb
+
+-- | Generate weight-balanced trees either by direct recursion or via
+-- 'fromSeq'. The former is much more likely to hit counterexamples to wrong
+-- @balance@ coefficients. We keep the latter generator around just in case,
+-- because it generates a more realistic distribution.
+instance (Integral k, Arbitrary k, Arbitrary a) => Arbitrary (FM k a) where
+  arbitrary = oneof [genFM, fromSeq <$> (arbitrary :: Gen [([k], a)])]
+  shrink (FM v m) = [FM v m | (v, FMB' m) <- shrinkTuple shrink shrinkFMB' (v, FMB' m)]
+
+instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where
+  coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb
+
+
+coarbitrary_maybe :: (CoArbitrary t) => Maybe t  -> Test.QuickCheck.Gen b
+                                                 -> Test.QuickCheck.Gen b
+coarbitrary_maybe Nothing = variant (0 :: Int)
+coarbitrary_maybe (Just x) = variant (1 :: Int) . coarbitrary x
+
+coarbitrary_fmb :: (CoArbitrary t1, CoArbitrary t) => FMB t t1 -> Gen a -> Gen a
+coarbitrary_fmb E = variant (0 :: Int)
+coarbitrary_fmb (I _ k x l (FMB' m) r) =
+        variant (1 :: Int) . coarbitrary k . coarbitrary_maybe x .
+        coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r
+
+instance Ord k => Semigroup (FM k a) where
+   (<>) = union
+instance Ord k => Monoid (FM k a) where
+   mempty  = empty
+   mappend = (SG.<>)
+   mconcat = unionSeq
+
+-- Testing
+
+genFM :: (Integral k, Arbitrary a) => Gen (FM k a)
+genFM = do
+  FM <$> arbitrary <*> genFMB_
+
+-- Choose the number of elements in the top layer upfront,
+-- and distribute it while recursing down.
+genFMB_ :: (Integral k, Arbitrary a) => Gen (FMB k a)
+genFMB_ = sized $ \sz -> do
+  n <- choose (0, sz)
+  resize (sz - n) (genFMB 0 n)
+
+-- Distribute the size @sz@ to generate the middle children of the nodes in the
+-- top layer.
+genFMB :: (Integral k, Arbitrary a) => Int -> Int -> Gen (FMB k a)
+genFMB i 0 = pure E
+genFMB i n = sized $ \sz -> do
+  let b = if n <= 2 then 0 else (n-1+balance) `div` (balance+1)
+  l <- choose (b, n-1-b)
+  z <- choose (0, sz)
+  m <- resize (min z (sz-z)) genFMB_
+  v <- case m of E -> Just <$> arbitrary ; _ -> arbitrary
+  let k = fromIntegral (i+l)
+  I n k v
+    <$> resize z (genFMB i l)
+    <*> pure (FMB' m)
+    <*> resize (sz - z) (genFMB (i+l+1) (n-l-1))
+
+-- Be careful to preserve balance during shrinking.
+shrinkFMB :: Arbitrary a => FMB k a -> [FMB k a]
+shrinkFMB E = []
+shrinkFMB (I s k v l m r) = E : l : r : do
+    let (*-) = shrinkTuple ; infixr 3 *-
+    (v, (l, (m@(FMB' m'), r))) <- (shrinkJust *- shrinkFMB *- shrinkFMB' *- shrinkFMB) (v, (l, (m, r)))
+    let s = sizeFMB l + sizeFMB r + 1
+        t = I s k v l m r
+    guard (isBalanced l r && (isJust v || not (nullFMB' m)))
+    pure t
+
+nullFMB' :: FMB' k v -> Bool
+nullFMB' (FMB' E) = True
+nullFMB' _ = False
+
+shrinkFMB' :: Arbitrary a => FMB' k a -> [FMB' k a]
+shrinkFMB' (FMB' m) = coerce $
+  tailsFMB m ++ shrinkFMB m
+
+-- List the middle children of the top layer.
+tailsFMB :: FMB k a -> [FMB k a]
+tailsFMB E = []
+tailsFMB (I _ _ _ l (FMB' m) r) = m : tailsFMB l ++ tailsFMB r
+
+-- Don't remove elements
+shrinkJust :: Arbitrary a => Maybe a -> [Maybe a]
+shrinkJust Nothing = []
+shrinkJust (Just x) = Just <$> shrink x
+
+shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
+shrinkTuple sa sb (a, b) = [(a', b) | a' <- sa a] ++ [(a, b') | b' <- sb b]

src/Data/Edison/Coll/Defaults.hs view

@@ -1,247 +1,249 @@--- |---   Module      :  Data.Edison.Coll.Defaults---   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  internal (unstable)---   Portability :  GHC / Hugs (MPTC and FD)------   This module provides default implementations of many of the collection methods.  The functions---   in this module are used to fill out collection implementations and are not intended to be---   used directly by end users.--module Data.Edison.Coll.Defaults where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Control.Monad.Fail as Fail--import Data.Edison.Prelude ( runFail_ )-import Data.Edison.Coll-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)--insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c-insertSeqUsingUnion xs c = union (fromSeq xs) c--insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c-insertSeqUsingFoldr xs c = S.foldr insert c xs--memberUsingFold :: Coll c a => c -> a -> Bool-memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h--countUsingMember :: SetX c a => a -> c -> Int-countUsingMember x xs = if member x xs then 1 else 0--lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a-lookupAllUsingLookupM x xs =-  case lookupM x xs of-    Nothing -> S.empty-    Just y  -> S.singleton y--deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c-deleteSeqUsingDelete xs c = S.foldr delete c xs--unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingFoldl = S.foldl union empty--unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingFoldl' = S.foldl' union empty--unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingReduce = S.reducel union empty--fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c-fromSeqUsingFoldr = S.foldr insert empty--fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c-fromSeqUsingUnionSeq = unionList . S.foldl singleCons []-  where singleCons xs x = S.lcons (singleton x) xs--toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a-toSeqUsingFold = fold S.lcons S.empty--unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c-unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x)--toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a-toOrdSeqUsingFoldr = foldr S.lcons S.empty--unsafeFromOrdSeqUsingUnsafeInsertMin ::-    (OrdCollX c a,S.Sequence seq) => seq a -> c-unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty--disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool-disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys)-  where disj a@(c:cs) b@(d:ds) =-          case compare c d of-            LT -> disj cs b-            EQ -> False-            GT -> disj a ds-        disj _ _ = True--intersectWitnessUsingToOrdList ::-        (OrdColl c a, Fail.MonadFail m) => c -> c -> m (a,a)-intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs)-  where witness a@(x:xs) b@(y:ys) =-          case compare x y of-            LT -> witness xs b-            EQ -> return (x, y)-            GT -> witness a ys-        -- XXX-        witness _ _ = fail $ instanceName as ++ ".intersect: failed"--lookupUsingLookupM :: Coll c a => a -> c -> a-lookupUsingLookupM x ys = runFail_ (lookupM x ys)--lookupUsingLookupAll :: Coll c a => a -> c -> a-lookupUsingLookupAll x ys =-  case lookupAll x ys of-    (y:_) -> y-    [] -> error $ instanceName ys ++ ".lookup: lookup failed"--lookupMUsingLookupAll :: (Coll c a, Fail.MonadFail m) => a -> c -> m a-lookupMUsingLookupAll x ys =-  case lookupAll x ys of-    (y:_) -> return y-    []    -> fail $ instanceName ys ++ ".lookupM: lookup failed"--lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a-lookupWithDefaultUsingLookupAll dflt x ys =-  case lookupAll x ys of-    (y:_) -> y-    [] -> dflt--lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a-lookupWithDefaultUsingLookupM dflt x ys =-  case lookupM x ys of-    Just y  -> y-    Nothing -> dflt--deleteMaxUsingMaxView :: OrdColl c a => c -> c-deleteMaxUsingMaxView c =-  case maxView c of-    Just (_,c') -> c'-    Nothing     -> c--fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c-fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty--insertUsingInsertWith :: Set c a => a -> c -> c-insertUsingInsertWith = insertWith (\x _ -> x)--unionUsingUnionWith :: Set c a => c -> c -> c-unionUsingUnionWith = unionWith (\x _ -> x)--filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c-filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList--partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c)-partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs)-  where (ys,zs) = L.partition p (toOrdList xs)--intersectionUsingIntersectionWith :: Set c a => c -> c -> c-intersectionUsingIntersectionWith = intersectionWith (\x _ -> x)--differenceUsingOrdLists :: OrdSet c a => c -> c -> c-differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs)-  where diff a@(x:xs) b@(y:ys) =-          case compare x y of-            LT -> x : diff xs b-            EQ -> diff xs ys-            GT -> diff a ys-        diff a _ = a--symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c-symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs)--properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool-properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys)--subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool-subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys)--properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool-properSubsetOnOrdLists [] [] = False-properSubsetOnOrdLists [] (_:_) = True-properSubsetOnOrdLists (_:_) [] = False-properSubsetOnOrdLists a@(x:xs) (y:ys) =-  case compare x y of-    LT -> False-    EQ -> properSubsetOnOrdLists xs ys-    GT -> subsetOnOrdLists a ys--subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool-subsetOnOrdLists [] _ = True-subsetOnOrdLists (_:_) [] = False-subsetOnOrdLists a@(x:xs) (y:ys) =-  case compare x y of-    LT -> False-    EQ -> subsetOnOrdLists xs ys-    GT -> subsetOnOrdLists a ys--insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c-insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs--unionlUsingUnionWith :: Set c a => c -> c -> c-unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys--unionrUsingUnionWith :: Set c a => c -> c -> c-unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys--unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c-unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs)-  where merge a@(x:xs) b@(y:ys) =-          case compare x y of-            LT -> x : merge xs b-            EQ -> c x y : merge xs ys-            GT -> y : merge a ys-        merge a [] = a-        merge [] b = b--unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c-unionSeqWithUsingReducer c = S.reducer (unionWith c) empty--intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c-intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs)-  where inter a@(x:xs) b@(y:ys) =-          case compare x y of-            LT -> inter xs b-            EQ -> c x y : inter xs ys-            GT -> inter a ys-        inter _ _ = []---unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout)-unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs--showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS-showsPrecUsingToList i xs rest-  | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]-  | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]--readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c-readsPrecUsingFromList _ xs =-    let result = maybeParens p xs-        p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys-                 >>= readsPrec 10-                 >>= \(l,rest) -> return (fromList l,rest)--        -- play games with the typechecker so we don't have to use-        -- extensions for scoped type variables-        ~[(x,_)] = result--    in result--compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering-compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs)- where-  cmp [] [] = EQ-  cmp [] _  = LT-  cmp _  [] = GT-  cmp (x:xs) (y:ys) =-      case compare x y of-         EQ -> cmp xs ys-         c -> c-+-- |
+--   Module      :  Data.Edison.Coll.Defaults
+--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  internal (unstable)
+--   Portability :  GHC / Hugs (MPTC and FD)
+--
+--   This module provides default implementations of many of the collection methods.  The functions
+--   in this module are used to fill out collection implementations and are not intended to be
+--   used directly by end users.
+
+module Data.Edison.Coll.Defaults where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Control.Monad.Fail as Fail
+
+import Data.Edison.Prelude ( runFail_ )
+import Data.Edison.Coll
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)
+
+insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c
+insertSeqUsingUnion xs c = union (fromSeq xs) c
+
+insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c
+insertSeqUsingFoldr xs c = S.foldr insert c xs
+
+memberUsingFold :: Coll c a => c -> a -> Bool
+memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h
+
+countUsingMember :: SetX c a => a -> c -> Int
+countUsingMember x xs = if member x xs then 1 else 0
+
+lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a
+lookupAllUsingLookupM x xs =
+  case lookupM x xs of
+    Nothing -> S.empty
+    Just y  -> S.singleton y
+
+deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c
+deleteSeqUsingDelete xs c = S.foldr delete c xs
+
+unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c
+unionSeqUsingFoldl = S.foldl union empty
+
+unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c
+unionSeqUsingFoldl' = S.foldl' union empty
+
+unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c
+unionSeqUsingReduce = S.reducel union empty
+
+fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c
+fromSeqUsingFoldr = S.foldr insert empty
+
+fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c
+fromSeqUsingUnionSeq = unionList . S.foldl singleCons []
+  where singleCons xs x = S.lcons (singleton x) xs
+
+toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a
+toSeqUsingFold = fold S.lcons S.empty
+
+unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c
+unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x)
+
+toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a
+toOrdSeqUsingFoldr = foldr S.lcons S.empty
+
+unsafeFromOrdSeqUsingUnsafeInsertMin ::
+    (OrdCollX c a,S.Sequence seq) => seq a -> c
+unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty
+
+disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool
+disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys)
+  where disj a@(c:cs) b@(d:ds) =
+          case compare c d of
+            LT -> disj cs b
+            EQ -> False
+            GT -> disj a ds
+        disj _ _ = True
+
+intersectWitnessUsingToOrdList ::
+        (OrdColl c a, Fail.MonadFail m) => c -> c -> m (a,a)
+intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs)
+  where witness a@(x:xs) b@(y:ys) =
+          case compare x y of
+            LT -> witness xs b
+            EQ -> return (x, y)
+            GT -> witness a ys
+        -- XXX
+        witness _ _ = fail $ instanceName as ++ ".intersect: failed"
+
+lookupUsingLookupM :: Coll c a => a -> c -> a
+lookupUsingLookupM x ys = runFail_ (lookupM x ys)
+
+lookupUsingLookupAll :: Coll c a => a -> c -> a
+lookupUsingLookupAll x ys =
+  case lookupAll x ys of
+    (y:_) -> y
+    [] -> error $ instanceName ys ++ ".lookup: lookup failed"
+
+lookupMUsingLookupAll :: (Coll c a, Fail.MonadFail m) => a -> c -> m a
+lookupMUsingLookupAll x ys =
+  case lookupAll x ys of
+    (y:_) -> return y
+    []    -> fail $ instanceName ys ++ ".lookupM: lookup failed"
+
+lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a
+lookupWithDefaultUsingLookupAll dflt x ys =
+  case lookupAll x ys of
+    (y:_) -> y
+    [] -> dflt
+
+lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a
+lookupWithDefaultUsingLookupM dflt x ys =
+  case lookupM x ys of
+    Just y  -> y
+    Nothing -> dflt
+
+deleteMaxUsingMaxView :: OrdColl c a => c -> c
+deleteMaxUsingMaxView c =
+  case maxView c of
+    Just (_,c') -> c'
+    Nothing     -> c
+
+fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c
+fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty
+
+insertUsingInsertWith :: Set c a => a -> c -> c
+insertUsingInsertWith = insertWith (\x _ -> x)
+
+unionUsingUnionWith :: Set c a => c -> c -> c
+unionUsingUnionWith = unionWith (\x _ -> x)
+
+filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c
+filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList
+
+partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c)
+partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs)
+  where (ys,zs) = L.partition p (toOrdList xs)
+
+intersectionUsingIntersectionWith :: Set c a => c -> c -> c
+intersectionUsingIntersectionWith = intersectionWith (\x _ -> x)
+
+differenceUsingOrdLists :: OrdSet c a => c -> c -> c
+differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs)
+  where diff a@(x:xs) b@(y:ys) =
+          case compare x y of
+            LT -> x : diff xs b
+            EQ -> diff xs ys
+            GT -> diff a ys
+        diff a _ = a
+
+symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c
+symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs)
+
+properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool
+properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys)
+
+subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool
+subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys)
+
+properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool
+properSubsetOnOrdLists [] [] = False
+properSubsetOnOrdLists [] (_:_) = True
+properSubsetOnOrdLists (_:_) [] = False
+properSubsetOnOrdLists a@(x:xs) (y:ys) =
+  case compare x y of
+    LT -> False
+    EQ -> properSubsetOnOrdLists xs ys
+    GT -> subsetOnOrdLists a ys
+
+subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool
+subsetOnOrdLists [] _ = True
+subsetOnOrdLists (_:_) [] = False
+subsetOnOrdLists a@(x:xs) (y:ys) =
+  case compare x y of
+    LT -> False
+    EQ -> subsetOnOrdLists xs ys
+    GT -> subsetOnOrdLists a ys
+
+insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c
+insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs
+
+unionlUsingUnionWith :: Set c a => c -> c -> c
+unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys
+
+unionrUsingUnionWith :: Set c a => c -> c -> c
+unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys
+
+unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c
+unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs)
+  where merge a@(x:xs) b@(y:ys) =
+          case compare x y of
+            LT -> x : merge xs b
+            EQ -> c x y : merge xs ys
+            GT -> y : merge a ys
+        merge a [] = a
+        merge [] b = b
+
+unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c
+unionSeqWithUsingReducer c = S.reducer (unionWith c) empty
+
+intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c
+intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs)
+  where inter a@(x:xs) b@(y:ys) =
+          case compare x y of
+            LT -> inter xs b
+            EQ -> c x y : inter xs ys
+            GT -> inter a ys
+        inter _ _ = []
+
+
+unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout)
+unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs
+
+showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS
+showsPrecUsingToList i xs rest
+  | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]
+  | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]
+
+readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c
+readsPrecUsingFromList _ xs =
+    let result = maybeParens p xs
+        p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys
+                 >>= readsPrec 10
+                 >>= \(l,rest) -> return (fromList l,rest)
+
+        -- play games with the typechecker so we don't have to use
+        -- extensions for scoped type variables
+        x = case result of
+          [(x',_)] -> x'
+          _ -> undefined
+
+    in result
+
+compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering
+compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs)
+ where
+  cmp [] [] = EQ
+  cmp [] _  = LT
+  cmp _  [] = GT
+  cmp (x:xs) (y:ys) =
+      case compare x y of
+         EQ -> cmp xs ys
+         c -> c
+

src/Data/Edison/Coll/EnumSet.hs view

@@ -1,808 +1,808 @@--------------------------------------------------------------------------------- |---   Module      :  Data.Edison.Coll.EnumSet---   Copyright   :  (c) David F. Place 2006---   License     :  BSD------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------ An efficient implementation of sets over small enumerations.--- The implementation of 'EnumSet' is based on bit-wise operations.------ For this implementation to work as expected at type @A@, there are a number--- of preconditions on the @Eq@, @Enum@ and @Ord@ instances.------ The @Enum A@ instance must create a bijection between the elements of type @A@ and--- a finite subset of the naturals [0,1,2,3....].  As a corollary we must have:------ > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y------ Also, the number of distinct elements of @A@ must be less than or equal--- to the number of bits in @Word@.------ The @Enum A@ instance must be consistent with the @Eq A@ instance.--- That is, we must have:------ > forall x y::A, x == y <==> toEnum x == toEnum y------ Additionally, for operations that require an @Ord A@ context, we require that--- toEnum be monotonic with respect to comparison.  That is, we must have:------ > forall x y::A, x < y <==> toEnum x < toEnum y------ Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if--- the enumerated type has sufficiently few constructors.--{--Copyright (c) 2006, 2008, David F. Place-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:---* Redistributions of source code must retain the above copyright-    notice, this list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright-    notice, this list of conditions and the following disclaimer in-    the documentation and/or other materials provided with the-    distribution.--* Neither the name of David F. Place nor the names of its-  contributors may be used to endorse or promote products derived from-  this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--module Data.Edison.Coll.EnumSet (-            -- * Set type-            Set--            -- * CollX operations-            , empty-            , singleton-            , fromSeq-            , insert-            , insertSeq-            , union-            , unionSeq-            , delete-            , deleteAll-            , deleteSeq-            , null-            , size-            , member-            , count-            , strict--            -- * OrdCollX operations-            , deleteMin-            , deleteMax-            , unsafeInsertMin-            , unsafeInsertMax-            , unsafeFromOrdSeq-            , unsafeAppend-            , filterLT-            , filterLE-            , filterGT-            , filterGE-            , partitionLT_GE-            , partitionLE_GT-            , partitionLT_GT--            -- * SetX operations-            , intersection-            , difference-            , symmetricDifference-            , properSubset-            , subset--            -- * Coll operations-            , toSeq-            , lookup-            , lookupM-            , lookupAll-            , lookupWithDefault-            , fold, fold', fold1, fold1'-            , filter-            , partition-            , strictWith--            -- * OrdColl operations-            , minView-            , minElem-            , maxView-            , maxElem-            , foldr, foldr', foldl, foldl'-            , foldr1, foldr1', foldl1, foldl1'-            , toOrdSeq-            , unsafeMapMonotonic--            -- * Set operations-            , fromSeqWith-            , fromOrdSeq-            , insertWith-            , insertSeqWith-            , unionl-            , unionr-            , unionWith-            , unionSeqWith-            , intersectionWith--            -- * Bonus operations-            , map-            , setCoerce-            , complement-            , toBits-            , fromBits--            -- * Documentation-            , moduleName-)  where--import qualified Prelude-import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1,foldl')-import qualified Control.Monad.Fail as Fail-import qualified Data.Bits as Bits-import Data.Bits hiding (complement)-import Data.Word-import Data.Monoid (Monoid(..))-import Data.Semigroup as SG--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Coll as C-import Data.Edison.Coll.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))--moduleName :: String-moduleName = "Data.Edison.Coll.EnumSet"--{---------------------------------------------------------------------  Sets are bit strings of width wordLength.---------------------------------------------------------------------}--- | A set of values @a@ implemented as bitwise operations.  Useful--- for members of class Enum with no more elements than there are bits--- in @Word@.-newtype Set a = Set Word deriving (Eq)--wordLength :: Int-wordLength =-#if MIN_VERSION_base(4,7,0)-  finiteBitSize-#else-  bitSize-#endif-    (0::Word)--check :: String -> Int -> Int-check msg x-    | x < wordLength = x-    | otherwise = error $ "EnumSet."++msg++": element beyond word size."----- no interesting structural invariants-structuralInvariant :: Set a -> Bool-structuralInvariant = const True---------------------------------------------------------- bit twiddly magic--countBits :: Word -> Int-countBits w = w `seq` bitcount 0 w--bitcount :: Int -> Word -> Int-bitcount a 0 = a-bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))---- stolen from http://aggregate.org/MAGIC/-lsb :: Word -> Int-lsb x = countBits ((x-1) .&. (Bits.complement x))--msb :: Word -> Int-msb x0 = let-     x1 = x0 .|. (x0 `shiftR` 1)-     x2 = x1 .|. (x1 `shiftR` 2)-     x3 = x2 .|. (x2 `shiftR` 4)-     x4 = x3 .|. (x3 `shiftR` 8)-     x5 = x4 .|. (x4 `shiftR` 16)-     in countBits x5 - 1---lowMask :: Int -> Word-lowMask x = bit x - 1--highMask :: Int -> Word-highMask x = Bits.complement (lowMask x)--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is this the empty set?-null :: Set a -> Bool-null (Set 0) = True-null _       = False---- | /O(1)/. The number of elements in the set.-size :: Set a -> Int-size (Set w) = countBits w---- | /O(1)/. Is the element in the set?-member :: (Eq a, Enum a) => a -> Set a -> Bool-member x (Set w) = testBit w $ fromEnum x--count :: (Eq a, Enum a) => a -> Set a -> Int-count = countUsingMember--lookup :: (Eq a, Enum a) => a -> Set a -> a-lookup = lookupUsingLookupAll--lookupM :: (Eq a, Enum a, Fail.MonadFail m) => a -> Set a -> m a-lookupM x s-   | member x s = return x-   | otherwise  = fail (moduleName++".lookupM: lookup failed")--lookupAll  :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a-lookupAll = lookupAllUsingLookupM--lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty :: Set a-empty = Set 0---- | /O(1)/. Create a singleton set.-singleton :: (Eq a, Enum a) => a -> Set a-singleton x =-    Set $ setBit 0 $ check "singleton" $ fromEnum x--{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | /O(1)/. Insert an element in a set.--- If the set already contains an element equal to the given value,--- it is replaced with the new value.-insert :: (Eq a, Enum a) => a -> Set a -> Set a-insert x (Set w) =-    Set $ setBit w $ check "insert" $ fromEnum x---- given the preconditions, we can just ignore the combining function-insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a-insertWith _ x (Set w) =-    Set $ setBit w $ check "insertWith" $ fromEnum x---- | /O(1)/. Delete an element from a set.-delete :: (Eq a, Enum a) => a -> Set a -> Set a-delete x (Set w) =-    Set $ clearBit w $ fromEnum x--deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a-deleteAll = delete--deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a-deleteSeq = deleteSeqUsingDelete--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(1)/. Is this a proper subset? (ie. a subset but not equal).-properSubset :: Set a -> Set a -> Bool-properSubset x y = (x /= y) && (subset x y)---- | /O(1)/. Is this a subset?--- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@.-subset :: Set a -> Set a -> Bool-subset x y = (x `union` y) == y--{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}---- | /O(1)/. The minimal element of a set.-minElem :: (Enum a) => Set a -> a-minElem (Set w)-   | w == 0    = error $ moduleName++".minElem: empty set"-   | otherwise = toEnum $ lsb w---- | /O(1)/. The maximal element of a set.-maxElem :: (Enum a) => Set a -> a-maxElem (Set w)-   | w == 0    = error $ moduleName++".maxElem: empty set"-   | otherwise = toEnum $ msb w---- | /O(1)/. Delete the minimal element.-deleteMin :: (Enum a) => Set a -> Set a-deleteMin (Set w)-   | w == 0    = empty-   | otherwise = Set $ clearBit w $ lsb w---- | /O(1)/. Delete the maximal element.-deleteMax :: (Enum a) => Set a -> Set a-deleteMax (Set w)-   | w == 0    = empty-   | otherwise = Set $ clearBit w $ msb w--minView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a)-minView (Set w)-   | w == 0    = fail (moduleName++".minView: empty set")-   | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i)--maxView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a)-maxView (Set w)-   | w == 0    = fail (moduleName++".maxView: empty set")-   | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i)--unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a-unsafeInsertMin = insert--unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a-unsafeInsertMax = insert--unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a-unsafeAppend = union--unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a-unsafeFromOrdSeq = fromSeq--filterLT :: (Ord a, Enum a) => a -> Set a -> Set a-filterLT x (Set w) = Set (w .&. lowMask (fromEnum x))--filterLE :: (Ord a, Enum a) => a -> Set a -> Set a-filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1))--filterGT :: (Ord a, Enum a) => a -> Set a -> Set a-filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1))--filterGE :: (Ord a, Enum a) => a -> Set a -> Set a-filterGE x (Set w) = Set (w .&. highMask (fromEnum x))--partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLT_GE x s = (filterLT x s,filterGE x s)--partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLE_GT x s = (filterLE x s,filterGT x s)--partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLT_GT x s = (filterLT x s,filterGT x s)---{---------------------------------------------------------------------  Union.---------------------------------------------------------------------}--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).-unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a-unionSeq = unionSeqUsingFoldl'---- | /O(1)/. The union of two sets.-union :: Set a -> Set a -> Set a-union (Set x) (Set y) = Set $ x .|. y--unionl :: Set a -> Set a -> Set a-unionl = union--unionr :: Set a -> Set a -> Set a-unionr = union---- given the preconditions, we can just ignore the combining function-unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a-unionWith _ = union--unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a-unionSeqWith _ = unionSeq--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(1)/. Difference of two sets.-difference :: Set a -> Set a -> Set a-difference (Set x) (Set y) = Set $ (x .|. y) `xor` y--symmetricDifference :: Set a -> Set a -> Set a-symmetricDifference (Set x) (Set y) = Set $ x `xor` y--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(1)/. The intersection of two sets.-intersection :: Set a -> Set a -> Set a-intersection (Set x) (Set y) = Set $ x .&. y--intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a-intersectionWith _ = intersection--{---------------------------------------------------------------------  Complement---------------------------------------------------------------------}--- | /O(1)/. The complement of a set with its universe set. @complement@ can be used---   with bounded types for which the universe set---   will be automatically created.-complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a-complement x = symmetricDifference u x-    where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy the predicate.-filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a-filter p (Set w) = Set $ foldlBits' f 0 w-    where-      f z i-        | p $ toEnum i = setBit z i-        | otherwise = z---- | /O(n)/. Partition the set into two sets, one with all elements that satisfy--- the predicate and one with all elements that don't satisfy the predicate.--- See also 'split'.-partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a)-partition p (Set w) = (Set yay,Set nay)-    where-      (yay,nay) = foldlBits' f (0,0) w-      f (x,y) i-          | p $ toEnum i = (setBit x i,y)-          | otherwise    = (x,setBit y i)---{-----------------------------------------------------------------------  Map-----------------------------------------------------------------------}--- | /O(n)/.--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@-map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b-map f0 (Set w) = Set $ foldlBits' f 0 w-    where-      f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i)--unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a-unsafeMapMonotonic = map---- | /O(1)/ Changes the type of the elements in the set without changing---   the representation.  Equivalent to @map (toEnum . fromEnum)@, and---   to @(fromBits . toBits)@.  This method is operationally a no-op.-setCoerce :: (Enum a, Enum b) => Set a -> Set b-setCoerce (Set w) = Set w---- | /O(1)/ Get the underlying bit-encoded representation.---   This method is operationally a no-op.-toBits :: Set a -> Word-toBits (Set w) = w---- | /O(1)/ Create an EnumSet from a bit-encoded representation.---   This method is operationally a no-op.-fromBits :: Word -> Set a-fromBits w = Set w---{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c-fold f z (Set w) = foldrBits folder z w-  where folder i = f (toEnum i)--fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c-fold' f z (Set w) = foldrBits' folder z w-  where folder i = f (toEnum i)--fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a-fold1 _ (Set 0) = error (moduleName++".fold1: empty set")-fold1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)-    where-      maxi = msb w-      folder i z = f (toEnum i) z--fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a-fold1' _ (Set 0) = error (moduleName++".fold1': empty set")-fold1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)-    where-      maxi = msb w-      folder i z = f (toEnum i) z--foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b-foldr f z (Set w) = foldrBits folder z w-  where folder i = f (toEnum i)--foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b-foldr' f z (Set w) = foldrBits' folder z w-  where folder i j = f (toEnum i) j--foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldr1 _ (Set 0) = error (moduleName ++ ".foldr1: empty set")-foldr1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)-    where-      maxi = msb w-      folder i z = f (toEnum i) z--foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldr1' _ (Set 0) = error (moduleName++".foldr1': empty set")-foldr1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)-    where-      maxi = msb w-      folder i z = f (toEnum i) z--foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c-foldl f z (Set w) = foldlBits folder z w-  where folder h i = f h (toEnum i)--foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c-foldl' f z (Set w) = foldlBits' folder z w-  where folder h i = f h (toEnum i)--foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldl1 _ (Set 0) = error (moduleName++".foldl1: empty set")-foldl1 f (Set w) = foldlBits folder (toEnum minimum) (clearBit w minimum)-  where-    minimum = lsb w-    folder z i = f z (toEnum i)--foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldl1' _ (Set 0) = error (moduleName++".foldl1': empty set")-foldl1' f (Set w) = foldlBits' folder (toEnum minimum) (clearBit w minimum)-  where-    minimum = lsb w-    folder z i = f z (toEnum i)--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a-fromSeq xs = Set $ S.fold' f 0 xs-  where f x z = setBit z $ check "fromSeq" $ fromEnum x--fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a-fromOrdSeq = fromSeq--insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a-insertSeq = insertSeqUsingUnion---- given the preconditions, we can just ignore the combining function-insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a-insertSeqWith _ = insertSeq--toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a-toSeq (Set w) = foldrBits f S.empty w-  where f i z = S.lcons (toEnum i) z--toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a-toOrdSeq = toSeq--fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a-fromSeqWith = fromSeqWithUsingInsertWith---{---------------------------------------------------------------------  Split---------------------------------------------------------------------}-{--splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a)-splitMember x (Set w) = (Set lesser,isMember,Set greater)-    where-      (lesser,isMember,greater) = foldrBits f (0,False,0) w-      f i (lesser,isMember,greater) =-        case compare (toEnum i) x of-          GT -> (lesser,isMember,setBit greater i)-          LT -> (setBit lesser i,isMember,greater)-          EQ -> (lesser,True,greater)--}---{-----------------------------------------------------------------  Strictness enhancement-----------------------------------------------------------------}--strict :: Set a -> Set a-strict s@(Set w) = w `seq` s--strictWith :: (a -> b) -> Set a -> Set a-strictWith _ s@(Set w) = w `seq` s--{---------------------------------------------------------------------  Utility functions.---------------------------------------------------------------------}--foldrBits :: (Int -> a -> a) -> a -> Word -> a-foldrBits f z w = foldrBits_aux f z 0 w--foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a-foldrBits_aux _ z _ 0 = z-foldrBits_aux f z i w-   | i `seq` w `seq` False = undefined-   | otherwise =-   case w .&. 0x0F of-     0x00 -> a-     0x01 -> f i $ a-     0x02 -> f (i+1) $ a-     0x03 -> f i $ f (i+1) $ a-     0x04 -> f (i+2) $ a-     0x05 -> f i $ f (i+2) $ a-     0x06 -> f (i+1) $ f (i+2) $ a-     0x07 -> f i $ f (i+1) $ f (i+2) $ a-     0x08 -> f (i+3) $ a-     0x09 -> f i $ f (i+3) $ a-     0x0A -> f (i+1) $ f (i+3) $ a-     0x0B -> f i $ f (i+1) $ f (i+3) $ a-     0x0C -> f (i+2) $ f (i+3) $ a-     0x0D -> f i $ f (i+2) $ f (i+3) $ a-     0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a-     0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a-     _ -> error "bug in foldrBits_aux"-- where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4)---foldrBits' :: (Int -> a -> a) -> a -> Word -> a-foldrBits' f z w = foldrBits_aux' f z 0 w--foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a-foldrBits_aux' _ z _ 0 = z-foldrBits_aux' f z i w-   | i `seq` w `seq` False = undefined-   | otherwise =-   case w .&. 0x0F of-     0x00 -> a-     0x01 -> f i $! a-     0x02 -> f (i+1) $! a-     0x03 -> f i $! f (i+1) $! a-     0x04 -> f (i+2) $! a-     0x05 -> f i $! f (i+2) $! a-     0x06 -> f (i+1) $! f (i+2) $! a-     0x07 -> f i $! f (i+1) $! f (i+2) $! a-     0x08 -> f (i+3) $! a-     0x09 -> f i $! f (i+3) $! a-     0x0A -> f (i+1) $! f (i+3) $! a-     0x0B -> f i $! f (i+1) $! f (i+3) $! a-     0x0C -> f (i+2) $! f (i+3) $! a-     0x0D -> f i $! f (i+2) $! f (i+3) $! a-     0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a-     0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a-     _ -> error "bug in foldrBits_aux'"-- where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4)---foldlBits :: (a -> Int -> a) -> a -> Word -> a-foldlBits f z w = foldlBits_aux f z 0 w--foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a-foldlBits_aux _ z _ 0 = z-foldlBits_aux f z i w-   | i `seq` w `seq` False = undefined-   | otherwise =-   case w .&. 0x0F of-     0x00 -> a $ z-     0x01 -> a $ f z i-     0x02 -> a $ f z (i+1)-     0x03 -> a $ f (f z i) (i+1)-     0x04 -> a $ f z (i+2)-     0x05 -> a $ f (f z i) (i+2)-     0x06 -> a $ f (f z (i+1)) (i+2)-     0x07 -> a $ f (f (f z i) (i+1)) (i+2)-     0x08 -> a $ f z (i+3)-     0x09 -> a $ f (f z i) (i+3)-     0x0A -> a $ f (f z (i+1)) (i+3)-     0x0B -> a $ f (f (f z i) (i+1)) (i+3)-     0x0C -> a $ f (f z (i+2)) (i+3)-     0x0D -> a $ f (f (f z i) (i+2)) (i+3)-     0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3)-     0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3)-     _ -> error "bug in foldlBits_aux"-- where a b = foldlBits_aux f b (i + 4) (Bits.shiftR w 4)--foldlBits' :: (a -> Int -> a) -> a -> Word -> a-foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w--foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a-foldlBits_aux' _ z _ 0 = z-foldlBits_aux' f z i w-   | i `seq` w `seq` False = undefined-   | otherwise =-   case w .&. 0x0F of-     0x00 -> a $! z-     0x01 -> a $! f z i-     0x02 -> a $! f z (i+1)-     0x03 -> a $! f (f z i) (i+1)-     0x04 -> a $! f z (i+2)-     0x05 -> a $! f (f z i) (i+2)-     0x06 -> a $! f (f z (i+1)) (i+2)-     0x07 -> a $! f (f (f z i) (i+1)) (i+2)-     0x08 -> a $! f z (i+3)-     0x09 -> a $! f (f z i) (i+3)-     0x0A -> a $! f (f z (i+1)) (i+3)-     0x0B -> a $! f (f (f z i) (i+1)) (i+3)-     0x0C -> a $! f (f z (i+2)) (i+3)-     0x0D -> a $! f (f (f z i) (i+2)) (i+3)-     0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3)-     0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3)-     _ -> error "bug in foldlBits_aux"-- where a b = foldlBits_aux' f b (i + 4) (Bits.shiftR w 4)--instance (Eq a, Enum a) => C.CollX (Set a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance (Ord a, Enum a) => C.OrdCollX (Set a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance (Eq a, Enum a) => C.SetX (Set a) a where-  {intersection = intersection; difference = difference;-   symmetricDifference = symmetricDifference;-   properSubset = properSubset; subset = subset}--instance (Eq a, Enum a) => C.Coll (Set a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance (Ord a, Enum a) => C.OrdColl (Set a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';-   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic}--instance (Eq a, Enum a) => C.Set (Set a) a where-  {fromSeqWith = fromSeqWith; insertWith = insertWith;-   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;-   unionWith = unionWith; unionSeqWith = unionSeqWith;-   intersectionWith = intersectionWith}--instance (Ord a, Enum a) => C.OrdSetX (Set a) a-instance (Ord a, Enum a) => C.OrdSet (Set a) a--instance (Eq a, Enum a, Show a) => Show (Set a) where-   showsPrec = showsPrecUsingToList--instance (Eq a, Enum a, Read a) => Read (Set a) where-   readsPrec = readsPrecUsingFromList--instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where-  arbitrary = do (w::Int) <- arbitrary-                 return (Set (fromIntegral w))--instance (Eq a, Enum a, CoArbitrary a) => CoArbitrary (Set a) where-  coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int)--instance (Eq a, Enum a) => Semigroup (Set a) where-    (<>) = union-instance (Eq a, Enum a) => Monoid (Set a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a, Enum a) => Ord (Set a) where-    compare = compareUsingToOrdList+-----------------------------------------------------------------------------
+-- |
+--   Module      :  Data.Edison.Coll.EnumSet
+--   Copyright   :  (c) David F. Place 2006
+--   License     :  BSD
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+-- An efficient implementation of sets over small enumerations.
+-- The implementation of 'EnumSet' is based on bit-wise operations.
+--
+-- For this implementation to work as expected at type @A@, there are a number
+-- of preconditions on the @Eq@, @Enum@ and @Ord@ instances.
+--
+-- The @Enum A@ instance must create a bijection between the elements of type @A@ and
+-- a finite subset of the naturals [0,1,2,3....].  As a corollary we must have:
+--
+-- > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y
+--
+-- Also, the number of distinct elements of @A@ must be less than or equal
+-- to the number of bits in @Word@.
+--
+-- The @Enum A@ instance must be consistent with the @Eq A@ instance.
+-- That is, we must have:
+--
+-- > forall x y::A, x == y <==> toEnum x == toEnum y
+--
+-- Additionally, for operations that require an @Ord A@ context, we require that
+-- toEnum be monotonic with respect to comparison.  That is, we must have:
+--
+-- > forall x y::A, x < y <==> toEnum x < toEnum y
+--
+-- Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if
+-- the enumerated type has sufficiently few constructors.
+
+{-
+Copyright (c) 2006, 2008, David F. Place
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+
+* Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution.
+
+* Neither the name of David F. Place nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+-}
+
+module Data.Edison.Coll.EnumSet (
+            -- * Set type
+            Set
+
+            -- * CollX operations
+            , empty
+            , singleton
+            , fromSeq
+            , insert
+            , insertSeq
+            , union
+            , unionSeq
+            , delete
+            , deleteAll
+            , deleteSeq
+            , null
+            , size
+            , member
+            , count
+            , strict
+
+            -- * OrdCollX operations
+            , deleteMin
+            , deleteMax
+            , unsafeInsertMin
+            , unsafeInsertMax
+            , unsafeFromOrdSeq
+            , unsafeAppend
+            , filterLT
+            , filterLE
+            , filterGT
+            , filterGE
+            , partitionLT_GE
+            , partitionLE_GT
+            , partitionLT_GT
+
+            -- * SetX operations
+            , intersection
+            , difference
+            , symmetricDifference
+            , properSubset
+            , subset
+
+            -- * Coll operations
+            , toSeq
+            , lookup
+            , lookupM
+            , lookupAll
+            , lookupWithDefault
+            , fold, fold', fold1, fold1'
+            , filter
+            , partition
+            , strictWith
+
+            -- * OrdColl operations
+            , minView
+            , minElem
+            , maxView
+            , maxElem
+            , foldr, foldr', foldl, foldl'
+            , foldr1, foldr1', foldl1, foldl1'
+            , toOrdSeq
+            , unsafeMapMonotonic
+
+            -- * Set operations
+            , fromSeqWith
+            , fromOrdSeq
+            , insertWith
+            , insertSeqWith
+            , unionl
+            , unionr
+            , unionWith
+            , unionSeqWith
+            , intersectionWith
+
+            -- * Bonus operations
+            , map
+            , setCoerce
+            , complement
+            , toBits
+            , fromBits
+
+            -- * Documentation
+            , moduleName
+)  where
+
+import qualified Prelude
+import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1,foldl')
+import qualified Control.Monad.Fail as Fail
+import qualified Data.Bits as Bits
+import Data.Bits hiding (complement)
+import Data.Word
+import Data.Monoid (Monoid(..))
+import Data.Semigroup as SG
+
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Coll as C
+import Data.Edison.Coll.Defaults
+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.EnumSet"
+
+{--------------------------------------------------------------------
+  Sets are bit strings of width wordLength.
+--------------------------------------------------------------------}
+-- | A set of values @a@ implemented as bitwise operations.  Useful
+-- for members of class Enum with no more elements than there are bits
+-- in @Word@.
+newtype Set a = Set Word deriving (Eq)
+
+wordLength :: Int
+wordLength =
+#if MIN_VERSION_base(4,7,0)
+  finiteBitSize
+#else
+  bitSize
+#endif
+    (0::Word)
+
+check :: String -> Int -> Int
+check msg x
+    | x < wordLength = x
+    | otherwise = error $ "EnumSet."++msg++": element beyond word size."
+
+
+-- no interesting structural invariants
+structuralInvariant :: Set a -> Bool
+structuralInvariant = const True
+
+
+----------------------------------------------------
+-- bit twiddly magic
+
+countBits :: Word -> Int
+countBits w = w `seq` bitcount 0 w
+
+bitcount :: Int -> Word -> Int
+bitcount a 0 = a
+bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))
+
+-- stolen from http://aggregate.org/MAGIC/
+lsb :: Word -> Int
+lsb x = countBits ((x-1) .&. (Bits.complement x))
+
+msb :: Word -> Int
+msb x0 = let
+     x1 = x0 .|. (x0 `shiftR` 1)
+     x2 = x1 .|. (x1 `shiftR` 2)
+     x3 = x2 .|. (x2 `shiftR` 4)
+     x4 = x3 .|. (x3 `shiftR` 8)
+     x5 = x4 .|. (x4 `shiftR` 16)
+     in countBits x5 - 1
+
+
+lowMask :: Int -> Word
+lowMask x = bit x - 1
+
+highMask :: Int -> Word
+highMask x = Bits.complement (lowMask x)
+
+{--------------------------------------------------------------------
+  Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is this the empty set?
+null :: Set a -> Bool
+null (Set 0) = True
+null _       = False
+
+-- | /O(1)/. The number of elements in the set.
+size :: Set a -> Int
+size (Set w) = countBits w
+
+-- | /O(1)/. Is the element in the set?
+member :: (Eq a, Enum a) => a -> Set a -> Bool
+member x (Set w) = testBit w $ fromEnum x
+
+count :: (Eq a, Enum a) => a -> Set a -> Int
+count = countUsingMember
+
+lookup :: (Eq a, Enum a) => a -> Set a -> a
+lookup = lookupUsingLookupAll
+
+lookupM :: (Eq a, Enum a, Fail.MonadFail m) => a -> Set a -> m a
+lookupM x s
+   | member x s = return x
+   | otherwise  = fail (moduleName++".lookupM: lookup failed")
+
+lookupAll  :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a
+lookupAll = lookupAllUsingLookupM
+
+lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a
+lookupWithDefault = lookupWithDefaultUsingLookupM
+
+{--------------------------------------------------------------------
+  Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: Set a
+empty = Set 0
+
+-- | /O(1)/. Create a singleton set.
+singleton :: (Eq a, Enum a) => a -> Set a
+singleton x =
+    Set $ setBit 0 $ check "singleton" $ fromEnum x
+
+{--------------------------------------------------------------------
+  Insertion, Deletion
+--------------------------------------------------------------------}
+-- | /O(1)/. Insert an element in a set.
+-- If the set already contains an element equal to the given value,
+-- it is replaced with the new value.
+insert :: (Eq a, Enum a) => a -> Set a -> Set a
+insert x (Set w) =
+    Set $ setBit w $ check "insert" $ fromEnum x
+
+-- given the preconditions, we can just ignore the combining function
+insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a
+insertWith _ x (Set w) =
+    Set $ setBit w $ check "insertWith" $ fromEnum x
+
+-- | /O(1)/. Delete an element from a set.
+delete :: (Eq a, Enum a) => a -> Set a -> Set a
+delete x (Set w) =
+    Set $ clearBit w $ fromEnum x
+
+deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a
+deleteAll = delete
+
+deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a
+deleteSeq = deleteSeqUsingDelete
+
+{--------------------------------------------------------------------
+  Subset
+--------------------------------------------------------------------}
+-- | /O(1)/. Is this a proper subset? (ie. a subset but not equal).
+properSubset :: Set a -> Set a -> Bool
+properSubset x y = (x /= y) && (subset x y)
+
+-- | /O(1)/. Is this a subset?
+-- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@.
+subset :: Set a -> Set a -> Bool
+subset x y = (x `union` y) == y
+
+{--------------------------------------------------------------------
+  Minimal, Maximal
+--------------------------------------------------------------------}
+
+-- | /O(1)/. The minimal element of a set.
+minElem :: (Enum a) => Set a -> a
+minElem (Set w)
+   | w == 0    = error $ moduleName++".minElem: empty set"
+   | otherwise = toEnum $ lsb w
+
+-- | /O(1)/. The maximal element of a set.
+maxElem :: (Enum a) => Set a -> a
+maxElem (Set w)
+   | w == 0    = error $ moduleName++".maxElem: empty set"
+   | otherwise = toEnum $ msb w
+
+-- | /O(1)/. Delete the minimal element.
+deleteMin :: (Enum a) => Set a -> Set a
+deleteMin (Set w)
+   | w == 0    = empty
+   | otherwise = Set $ clearBit w $ lsb w
+
+-- | /O(1)/. Delete the maximal element.
+deleteMax :: (Enum a) => Set a -> Set a
+deleteMax (Set w)
+   | w == 0    = empty
+   | otherwise = Set $ clearBit w $ msb w
+
+minView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a)
+minView (Set w)
+   | w == 0    = fail (moduleName++".minView: empty set")
+   | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i)
+
+maxView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a)
+maxView (Set w)
+   | w == 0    = fail (moduleName++".maxView: empty set")
+   | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i)
+
+unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a
+unsafeInsertMin = insert
+
+unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a
+unsafeInsertMax = insert
+
+unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a
+unsafeAppend = union
+
+unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a
+unsafeFromOrdSeq = fromSeq
+
+filterLT :: (Ord a, Enum a) => a -> Set a -> Set a
+filterLT x (Set w) = Set (w .&. lowMask (fromEnum x))
+
+filterLE :: (Ord a, Enum a) => a -> Set a -> Set a
+filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1))
+
+filterGT :: (Ord a, Enum a) => a -> Set a -> Set a
+filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1))
+
+filterGE :: (Ord a, Enum a) => a -> Set a -> Set a
+filterGE x (Set w) = Set (w .&. highMask (fromEnum x))
+
+partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)
+partitionLT_GE x s = (filterLT x s,filterGE x s)
+
+partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)
+partitionLE_GT x s = (filterLE x s,filterGT x s)
+
+partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)
+partitionLT_GT x s = (filterLT x s,filterGT x s)
+
+
+{--------------------------------------------------------------------
+  Union.
+--------------------------------------------------------------------}
+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
+unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a
+unionSeq = unionSeqUsingFoldl'
+
+-- | /O(1)/. The union of two sets.
+union :: Set a -> Set a -> Set a
+union (Set x) (Set y) = Set $ x .|. y
+
+unionl :: Set a -> Set a -> Set a
+unionl = union
+
+unionr :: Set a -> Set a -> Set a
+unionr = union
+
+-- given the preconditions, we can just ignore the combining function
+unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a
+unionWith _ = union
+
+unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a
+unionSeqWith _ = unionSeq
+
+{--------------------------------------------------------------------
+  Difference
+--------------------------------------------------------------------}
+-- | /O(1)/. Difference of two sets.
+difference :: Set a -> Set a -> Set a
+difference (Set x) (Set y) = Set $ (x .|. y) `xor` y
+
+symmetricDifference :: Set a -> Set a -> Set a
+symmetricDifference (Set x) (Set y) = Set $ x `xor` y
+
+{--------------------------------------------------------------------
+  Intersection
+--------------------------------------------------------------------}
+-- | /O(1)/. The intersection of two sets.
+intersection :: Set a -> Set a -> Set a
+intersection (Set x) (Set y) = Set $ x .&. y
+
+intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a
+intersectionWith _ = intersection
+
+{--------------------------------------------------------------------
+  Complement
+--------------------------------------------------------------------}
+-- | /O(1)/. The complement of a set with its universe set. @complement@ can be used
+--   with bounded types for which the universe set
+--   will be automatically created.
+complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a
+complement x = symmetricDifference u x
+    where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x
+
+{--------------------------------------------------------------------
+  Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy the predicate.
+filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a
+filter p (Set w) = Set $ foldlBits' f 0 w
+    where
+      f z i
+        | p $ toEnum i = setBit z i
+        | otherwise = z
+
+-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
+-- the predicate and one with all elements that don't satisfy the predicate.
+-- See also 'split'.
+partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a)
+partition p (Set w) = (Set yay,Set nay)
+    where
+      (yay,nay) = foldlBits' f (0,0) w
+      f (x,y) i
+          | p $ toEnum i = (setBit x i,y)
+          | otherwise    = (x,setBit y i)
+
+
+{----------------------------------------------------------------------
+  Map
+----------------------------------------------------------------------}
+-- | /O(n)/.
+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b
+map f0 (Set w) = Set $ foldlBits' f 0 w
+    where
+      f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i)
+
+unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a
+unsafeMapMonotonic = map
+
+-- | /O(1)/ Changes the type of the elements in the set without changing
+--   the representation.  Equivalent to @map (toEnum . fromEnum)@, and
+--   to @(fromBits . toBits)@.  This method is operationally a no-op.
+setCoerce :: (Enum a, Enum b) => Set a -> Set b
+setCoerce (Set w) = Set w
+
+-- | /O(1)/ Get the underlying bit-encoded representation.
+--   This method is operationally a no-op.
+toBits :: Set a -> Word
+toBits (Set w) = w
+
+-- | /O(1)/ Create an EnumSet from a bit-encoded representation.
+--   This method is operationally a no-op.
+fromBits :: Word -> Set a
+fromBits w = Set w
+
+
+{--------------------------------------------------------------------
+  Fold
+--------------------------------------------------------------------}
+
+fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c
+fold f z (Set w) = foldrBits folder z w
+  where folder i = f (toEnum i)
+
+fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c
+fold' f z (Set w) = foldrBits' folder z w
+  where folder i = f (toEnum i)
+
+fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a
+fold1 _ (Set 0) = error (moduleName++".fold1: empty set")
+fold1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)
+    where
+      maxi = msb w
+      folder i z = f (toEnum i) z
+
+fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a
+fold1' _ (Set 0) = error (moduleName++".fold1': empty set")
+fold1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)
+    where
+      maxi = msb w
+      folder i z = f (toEnum i) z
+
+foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b
+foldr f z (Set w) = foldrBits folder z w
+  where folder i = f (toEnum i)
+
+foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b
+foldr' f z (Set w) = foldrBits' folder z w
+  where folder i j = f (toEnum i) j
+
+foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a
+foldr1 _ (Set 0) = error (moduleName ++ ".foldr1: empty set")
+foldr1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)
+    where
+      maxi = msb w
+      folder i z = f (toEnum i) z
+
+foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a
+foldr1' _ (Set 0) = error (moduleName++".foldr1': empty set")
+foldr1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)
+    where
+      maxi = msb w
+      folder i z = f (toEnum i) z
+
+foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c
+foldl f z (Set w) = foldlBits folder z w
+  where folder h i = f h (toEnum i)
+
+foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c
+foldl' f z (Set w) = foldlBits' folder z w
+  where folder h i = f h (toEnum i)
+
+foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a
+foldl1 _ (Set 0) = error (moduleName++".foldl1: empty set")
+foldl1 f (Set w) = foldlBits folder (toEnum minimum) (clearBit w minimum)
+  where
+    minimum = lsb w
+    folder z i = f z (toEnum i)
+
+foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a
+foldl1' _ (Set 0) = error (moduleName++".foldl1': empty set")
+foldl1' f (Set w) = foldlBits' folder (toEnum minimum) (clearBit w minimum)
+  where
+    minimum = lsb w
+    folder z i = f z (toEnum i)
+
+{--------------------------------------------------------------------
+  Lists
+--------------------------------------------------------------------}
+fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a
+fromSeq xs = Set $ S.fold' f 0 xs
+  where f x z = setBit z $ check "fromSeq" $ fromEnum x
+
+fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a
+fromOrdSeq = fromSeq
+
+insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a
+insertSeq = insertSeqUsingUnion
+
+-- given the preconditions, we can just ignore the combining function
+insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a
+insertSeqWith _ = insertSeq
+
+toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a
+toSeq (Set w) = foldrBits f S.empty w
+  where f i z = S.lcons (toEnum i) z
+
+toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a
+toOrdSeq = toSeq
+
+fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a
+fromSeqWith = fromSeqWithUsingInsertWith
+
+
+{--------------------------------------------------------------------
+  Split
+--------------------------------------------------------------------}
+{-
+splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a)
+splitMember x (Set w) = (Set lesser,isMember,Set greater)
+    where
+      (lesser,isMember,greater) = foldrBits f (0,False,0) w
+      f i (lesser,isMember,greater) =
+        case compare (toEnum i) x of
+          GT -> (lesser,isMember,setBit greater i)
+          LT -> (setBit lesser i,isMember,greater)
+          EQ -> (lesser,True,greater)
+-}
+
+
+{----------------------------------------------------------------
+  Strictness enhancement
+----------------------------------------------------------------}
+
+strict :: Set a -> Set a
+strict s@(Set w) = w `seq` s
+
+strictWith :: (a -> b) -> Set a -> Set a
+strictWith _ s@(Set w) = w `seq` s
+
+{--------------------------------------------------------------------
+  Utility functions.
+--------------------------------------------------------------------}
+
+foldrBits :: (Int -> a -> a) -> a -> Word -> a
+foldrBits f z w = foldrBits_aux f z 0 w
+
+foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a
+foldrBits_aux _ z _ 0 = z
+foldrBits_aux f z i w
+   | i `seq` w `seq` False = undefined
+   | otherwise =
+   case w .&. 0x0F of
+     0x00 -> a
+     0x01 -> f i $ a
+     0x02 -> f (i+1) $ a
+     0x03 -> f i $ f (i+1) $ a
+     0x04 -> f (i+2) $ a
+     0x05 -> f i $ f (i+2) $ a
+     0x06 -> f (i+1) $ f (i+2) $ a
+     0x07 -> f i $ f (i+1) $ f (i+2) $ a
+     0x08 -> f (i+3) $ a
+     0x09 -> f i $ f (i+3) $ a
+     0x0A -> f (i+1) $ f (i+3) $ a
+     0x0B -> f i $ f (i+1) $ f (i+3) $ a
+     0x0C -> f (i+2) $ f (i+3) $ a
+     0x0D -> f i $ f (i+2) $ f (i+3) $ a
+     0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a
+     0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a
+     _ -> error "bug in foldrBits_aux"
+
+ where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4)
+
+
+foldrBits' :: (Int -> a -> a) -> a -> Word -> a
+foldrBits' f z w = foldrBits_aux' f z 0 w
+
+foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a
+foldrBits_aux' _ z _ 0 = z
+foldrBits_aux' f z i w
+   | i `seq` w `seq` False = undefined
+   | otherwise =
+   case w .&. 0x0F of
+     0x00 -> a
+     0x01 -> f i $! a
+     0x02 -> f (i+1) $! a
+     0x03 -> f i $! f (i+1) $! a
+     0x04 -> f (i+2) $! a
+     0x05 -> f i $! f (i+2) $! a
+     0x06 -> f (i+1) $! f (i+2) $! a
+     0x07 -> f i $! f (i+1) $! f (i+2) $! a
+     0x08 -> f (i+3) $! a
+     0x09 -> f i $! f (i+3) $! a
+     0x0A -> f (i+1) $! f (i+3) $! a
+     0x0B -> f i $! f (i+1) $! f (i+3) $! a
+     0x0C -> f (i+2) $! f (i+3) $! a
+     0x0D -> f i $! f (i+2) $! f (i+3) $! a
+     0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a
+     0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a
+     _ -> error "bug in foldrBits_aux'"
+
+ where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4)
+
+
+foldlBits :: (a -> Int -> a) -> a -> Word -> a
+foldlBits f z w = foldlBits_aux f z 0 w
+
+foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a
+foldlBits_aux _ z _ 0 = z
+foldlBits_aux f z i w
+   | i `seq` w `seq` False = undefined
+   | otherwise =
+   case w .&. 0x0F of
+     0x00 -> a $ z
+     0x01 -> a $ f z i
+     0x02 -> a $ f z (i+1)
+     0x03 -> a $ f (f z i) (i+1)
+     0x04 -> a $ f z (i+2)
+     0x05 -> a $ f (f z i) (i+2)
+     0x06 -> a $ f (f z (i+1)) (i+2)
+     0x07 -> a $ f (f (f z i) (i+1)) (i+2)
+     0x08 -> a $ f z (i+3)
+     0x09 -> a $ f (f z i) (i+3)
+     0x0A -> a $ f (f z (i+1)) (i+3)
+     0x0B -> a $ f (f (f z i) (i+1)) (i+3)
+     0x0C -> a $ f (f z (i+2)) (i+3)
+     0x0D -> a $ f (f (f z i) (i+2)) (i+3)
+     0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3)
+     0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3)
+     _ -> error "bug in foldlBits_aux"
+
+ where a b = foldlBits_aux f b (i + 4) (Bits.shiftR w 4)
+
+foldlBits' :: (a -> Int -> a) -> a -> Word -> a
+foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w
+
+foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a
+foldlBits_aux' _ z _ 0 = z
+foldlBits_aux' f z i w
+   | i `seq` w `seq` False = undefined
+   | otherwise =
+   case w .&. 0x0F of
+     0x00 -> a $! z
+     0x01 -> a $! f z i
+     0x02 -> a $! f z (i+1)
+     0x03 -> a $! f (f z i) (i+1)
+     0x04 -> a $! f z (i+2)
+     0x05 -> a $! f (f z i) (i+2)
+     0x06 -> a $! f (f z (i+1)) (i+2)
+     0x07 -> a $! f (f (f z i) (i+1)) (i+2)
+     0x08 -> a $! f z (i+3)
+     0x09 -> a $! f (f z i) (i+3)
+     0x0A -> a $! f (f z (i+1)) (i+3)
+     0x0B -> a $! f (f (f z i) (i+1)) (i+3)
+     0x0C -> a $! f (f z (i+2)) (i+3)
+     0x0D -> a $! f (f (f z i) (i+2)) (i+3)
+     0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3)
+     0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3)
+     _ -> error "bug in foldlBits_aux"
+
+ where a b = foldlBits_aux' f b (i + 4) (Bits.shiftR w 4)
+
+instance (Eq a, Enum a) => C.CollX (Set a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance (Ord a, Enum a) => C.OrdCollX (Set a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance (Eq a, Enum a) => C.SetX (Set a) a where
+  {intersection = intersection; difference = difference;
+   symmetricDifference = symmetricDifference;
+   properSubset = properSubset; subset = subset}
+
+instance (Eq a, Enum a) => C.Coll (Set a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance (Ord a, Enum a) => C.OrdColl (Set a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';
+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic}
+
+instance (Eq a, Enum a) => C.Set (Set a) a where
+  {fromSeqWith = fromSeqWith; insertWith = insertWith;
+   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;
+   unionWith = unionWith; unionSeqWith = unionSeqWith;
+   intersectionWith = intersectionWith}
+
+instance (Ord a, Enum a) => C.OrdSetX (Set a) a
+instance (Ord a, Enum a) => C.OrdSet (Set a) a
+
+instance (Eq a, Enum a, Show a) => Show (Set a) where
+   showsPrec = showsPrecUsingToList
+
+instance (Eq a, Enum a, Read a) => Read (Set a) where
+   readsPrec = readsPrecUsingFromList
+
+instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where
+  arbitrary = do (w::Int) <- arbitrary
+                 return (Set (fromIntegral w))
+
+instance (Eq a, Enum a, CoArbitrary a) => CoArbitrary (Set a) where
+  coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int)
+
+instance (Eq a, Enum a) => Semigroup (Set a) where
+    (<>) = union
+instance (Eq a, Enum a) => Monoid (Set a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a, Enum a) => Ord (Set a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/LazyPairingHeap.hs view

@@ -1,570 +1,572 @@--- |---   Module      :  Data.Edison.Coll.LazyPairingHeap---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Lazy Paring Heaps------   /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.---   Section 6.5.--module Data.Edison.Coll.LazyPairingHeap (-    -- * Type of pairing heaps-    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',-    fold1, fold1', filter, partition, strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,-    unsafeMapMonotonic,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..),-                                   Coll(..), OrdColl(..), toOrdList )-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.List (sort)-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.LazyPairingHeap"---data Heap a = E-            | H1 a (Heap a)-            | H2 a !(Heap a) (Heap a)----- Invariants:---   * left child of H2 not empty-structuralInvariant :: Heap a -> Bool-structuralInvariant E = True-structuralInvariant (H1 _ h) = structuralInvariant h-structuralInvariant (H2 _ E _) = False-structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r---- second arg is not empty--- not used!--- link E h = h--- link (H1 x b) a = H2 x a b--- link (H2 x a b) a' = H1 x (union (union a a') b)--makeH2 :: a -> Heap a -> Heap a -> Heap a-makeH2 x E xs = H1 x xs-makeH2 x h xs = H2 x h xs--empty :: Heap a-empty = E--singleton :: a -> Heap a-singleton x = H1 x E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = H1 x E-insert x h@(H1 y b)-  | x <= y    = H1 x h-  | otherwise = H2 y (H1 x E) b-insert x h@(H2 y a b)-  | x <= y    = H1 x h-  | otherwise = H1 y (union (insert x a) b)--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union hx@(H1 _ _) E = hx-union hx@(H1 x xs) hy@(H1 y ys)-  | x <= y    = H2 x hy xs-  | otherwise = H2 y hx ys-union hx@(H1 x xs) hy@(H2 y a ys)-  | x <= y    = H2 x hy xs-  | otherwise = H1 y (union (union hx a) ys)-union hx@(H2 _ _ _) E = hx-union hx@(H2 x a xs) hy@(H1 y ys)-  | x <= y    = H1 x (union (union hy a) xs)-  | otherwise = H2 y hx ys-union hx@(H2 x a xs) hy@(H2 y b ys)-  | x <= y    = H1 x (union (union hy a) xs)-  | otherwise = H1 y (union (union hx b) ys)--delete :: Ord a => a -> Heap a -> Heap a-delete y h = case del h of Just h' -> h'-                           Nothing -> h-  where del E = Nothing-        del (H1 x xs) =-          case compare x y of-            LT -> case del xs of-                    Just ys -> Just (H1 x ys)-                    Nothing -> Nothing-            EQ -> Just xs-            GT -> Nothing-        del (H2 x a xs) =-          case compare x y of-            LT -> case del a of-                    Just a' -> Just (makeH2 x a' xs)-                    Nothing -> case del xs of-                                 Just xs' -> Just (H2 x a xs')-                                 Nothing -> Nothing-            EQ -> Just (union a xs)-            GT -> Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll _ E = E-deleteAll y h@(H1 x xs) =-  case compare x y of-    LT -> H1 x (deleteAll y xs)-    EQ -> deleteAll y xs-    GT -> h-deleteAll y h@(H2 x a xs) =-  case compare x y of-    LT -> makeH2 x (deleteAll y a) (deleteAll y xs)-    EQ -> union (deleteAll y a) (deleteAll y xs)-    GT -> h--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = delList . sort . S.toList-  where delList [] h = h-        delList (y:ys) h = del y ys h--        del _ _ E = E-        del y ys h@(H1 x xs) =-          case compare x y of-            LT -> H1 x (del y ys xs)-            EQ -> delList ys xs-            GT -> delList ys h-        del y ys h@(H2 x a xs) =-          case compare x y of-            LT -> H1 x (del y ys (union a xs))-            EQ -> delList ys (union a xs)-            GT -> delList ys h-        {--           could write the two GT cases as-             delList (dropWhile (< x) ys) h-           but this is only a win if we expect many of the ys-           to be missing from the tree.  However, we expect most-           of the ys to be present.-        -}--null :: Heap a -> Bool-null E = True-null _ = False--size :: Heap a -> Int-size E = 0-size (H1 _ xs) = 1 + size xs-size (H2 _ h xs) = 1 + size h + size xs--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (H1 y ys) =-  case compare x y of-    LT -> False-    EQ -> True-    GT -> member x ys-member x (H2 y h ys) =-  case compare x y of-    LT -> False-    EQ -> True-    GT -> member x h || member x ys--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (H1 y ys) =-  case compare x y of-    LT -> 0-    EQ -> 1 + count x ys-    GT -> count x ys-count x (H2 y h ys) =-  case compare x y of-    LT -> 0-    EQ -> 1 + count x h + count x ys-    GT -> count x h + count x ys--deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (H1 _ xs) = xs-deleteMin (H2 _ h xs) = union h xs--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin = H1--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax x E = H1 x E-unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys-unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys)--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend h E = h-unsafeAppend E h = h-unsafeAppend (H1 x xs) h = H2 x h xs-unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs)--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT _ E = E-filterLT y (H1 x xs)-  | x < y = H1 x (filterLT y xs)-  | otherwise = E-filterLT y (H2 x h xs)-  | x < y = makeH2 x (filterLT y h) (filterLT y xs)-  | otherwise = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE _ E = E-filterLE y (H1 x xs)-  | x <= y = H1 x (filterLE y xs)-  | otherwise = E-filterLE y (H2 x h xs)-  | x <= y = makeH2 x (filterLE y h) (filterLE y xs)-  | otherwise = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = fgt h E-  where fgt E rest = rest-        fgt i@(H1 x xs) rest-          | x > y = union i rest-          | otherwise = fgt xs rest-        fgt i@(H2 x a xs) rest-          | x > y = union i rest-          | otherwise = fgt a (fgt xs rest)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = fge h E-  where fge E rest = rest-        fge i@(H1 x xs) rest-          | x >= y = union i rest-          | otherwise = fge xs rest-        fge i@(H2 x a xs) rest-          | x >= y = union i rest-          | otherwise = fge a (fge xs rest)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE _ E = (E,E)-partitionLT_GE y h@(H1 x xs)-  | x < y = let (xs',xs'') = partitionLT_GE y xs-            in (H1 x xs',xs'')-  | otherwise = (E, h)-partitionLT_GE y h@(H2 x a xs)-  | x < y = let (a',a'') = partitionLT_GE y a-                (xs',xs'') = partitionLT_GE y xs-            in (makeH2 x a' xs',union a'' xs'')-  | otherwise = (E, h)--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT _ E = (E,E)-partitionLE_GT y h@(H1 x xs)-  | x <= y = let (xs',xs'') = partitionLE_GT y xs-             in (H1 x xs',xs'')-  | otherwise = (E, h)-partitionLE_GT y h@(H2 x a xs)-  | x <= y = let (a',a'') = partitionLE_GT y a-                 (xs',xs'') = partitionLE_GT y xs-             in (makeH2 x a' xs',union a'' xs'')-  | otherwise = (E, h)--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT _ E = (E,E)-partitionLT_GT y h@(H1 x xs) =-  case compare x y of-    LT -> let (xs',xs'') = partitionLT_GT y xs-          in (H1 x xs',xs'')-    EQ -> (E, filterGT y xs)-    GT -> (E, h)-partitionLT_GT y h@(H2 x a xs) =-  case compare x y of-    LT -> let (a',a'') = partitionLT_GT y a-              (xs',xs'') = partitionLT_GT y xs-          in (makeH2 x a' xs',union a'' xs'')-    EQ -> (E, union (filterGT y a) (filterGT y xs))-    GT -> (E, h)--toSeq :: S.Sequence seq => Heap a -> seq a-toSeq h = tol h S.empty-  where tol E rest = rest-        tol (H1 x xs) rest = S.lcons x (tol xs rest)-        tol (H2 x i xs) rest = S.lcons x $ tol i $ tol xs rest--fold :: (a -> b -> b) -> b -> Heap a -> b-fold _ c E = c-fold f c (H1 x xs) = f x (fold f c xs)-fold f c (H2 x h xs) = f x (fold f (fold f c xs) h)--fold' :: (a -> b -> b) -> b -> Heap a -> b-fold' _ c E = c-fold' f c (H1 x xs)   = c `seq` f x $! (fold' f c xs)-fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h)---fold1 :: (a -> a -> a) -> Heap a -> a-fold1 _ E = error "LazyPairingHeap.fold1: empty heap"-fold1 f (H1 x xs) = fold f x xs-fold1 f (H2 x h xs) = fold f (fold f x xs) h--fold1' :: (a -> a -> a) -> Heap a -> a-fold1' _ E = error "LazyPairingHeap.fold1': empty heap"-fold1' f (H1 x xs)   = fold' f x xs-fold1' f (H2 x h xs) = fold' f (fold' f x xs) h---filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs-filter p (H2 x h xs) =-  if p x then makeH2 x (filter p h) (filter p xs)-         else union (filter p h) (filter p xs)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'')-    where (xs',xs'') = partition p xs-partition p (H2 x h xs) =-  if p x then (makeH2 x h' xs', union h'' xs'')-         else (union h' xs', makeH2 x h'' xs'')-    where (h',h'') = partition p h-          (xs',xs'') = partition p xs--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll y h = look h S.empty-  where look E rest = rest-        look (H1 x xs) rest =-          case compare x y of-            LT -> look xs rest-            EQ -> S.lcons x (look xs rest)-            GT -> rest-        look (H2 x i xs) rest =-          case compare x y of-            LT -> look i $ look xs rest-            EQ -> S.lcons x $ look i $ look xs rest-            GT -> rest--minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-minView E = fail "LazyPairingHeap.minView: empty heap"-minView (H1 x xs) = return (x,xs)-minView (H2 x h xs) = return (x,union h xs)--minElem :: Heap a -> a-minElem E = error "LazyPairingHeap.minElem: empty heap"-minElem (H1 x _) = x-minElem (H2 x _ _) = x--maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-maxView E = fail "LazyPairingHeap.maxView: empty heap"-maxView xs = return (y,xs')-  where (xs', y) = maxView' xs---- not exported-maxView' :: (Ord a) => Heap a -> (Heap a, a)-maxView' (H1 x E) = (E, x)-maxView' (H1 x xs) = (H1 x xs', y)-  where (xs', y) = maxView' xs-maxView' (H2 x a E) = (H1 x a', y)-  where (a', y) = maxView' a-maxView' (H2 x a xs) =-    if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z)-  where (a', y) = maxView' a-        (xs', z) = maxView' xs-maxView' E = error "LazyPairingHeap.maxView': bug!"--maxElem :: Ord a => Heap a -> a-maxElem E = error "LazyPairingHeap.maxElem: empty heap"-maxElem (H1 x E) = x-maxElem (H1 _ xs) = maxElem xs-maxElem (H2 _ h E) = maxElem h-maxElem (H2 _ h xs) = max (maxElem h) (maxElem xs)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ c E = c-foldr f c (H1 x xs) = f x (foldr f c xs)-foldr f c (H2 x h xs) = f x (foldr f c (union h xs))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ c E = c-foldr' f c (H1 x xs)   = c `seq` f x $! (foldr' f c xs)-foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ c E = c-foldl f c (H1 x xs) = foldl f (f c x) xs-foldl f c (H2 x h xs) = foldl f (f c x) (union h xs)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ c E = c-foldl' f c (H1 x xs)   = c `seq` foldl' f (f c x) xs-foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "LazyPairingHeap.foldr1: empty heap"-foldr1 _ (H1 x E) = x-foldr1 f (H1 x xs) = f x (foldr1 f xs)-foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "LazyPairingHeap.foldr1': empty heap"-foldr1' _ (H1 x E)    = x-foldr1' f (H1 x xs)   = f x $! (foldr1' f xs)-foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "LazyPairingHeap.foldl1: empty heap"-foldl1 f (H1 x xs) = foldl f x xs-foldl1 f (H2 x h xs) = foldl f x (union h xs)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "LazyPairingHeap.foldl1': empty heap"-foldl1' f (H1 x xs)   = foldl' f x xs-foldl1' f (H2 x h xs) = foldl' f x (union h xs)--unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b-unsafeMapMonotonic = mapm-  where mapm _ E = E-        mapm f (H1 x xs) = H1 (f x) (mapm f xs)-        mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs)---strict :: Heap a -> Heap a-strict h@E = h-strict h@(H1 _ xs) = strict xs `seq` h-strict h@(H2 _ h' xs) = strict h' `seq` strict xs `seq` h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h-strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h----- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingFoldr--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingFoldr--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingFoldl--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--deleteMax :: Ord a => Heap a -> Heap a-deleteMax = deleteMaxUsingMaxView--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupAll--lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a-lookupM = lookupMUsingLookupAll--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupAll--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr---- instance declarations--instance Ord a => C.CollX (Heap a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;-   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where-  xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where-  showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where-  readsPrec = readsPrecUsingFromList--instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where-  arbitrary = sized (\n -> arbTree n)-    where arbTree 0 = return E-          arbTree n =-            frequency [(1, return E),-                       (2, liftM2 sift1 arbitrary (arbTree (n - 1))),-                       (3, liftM3 sift arbitrary (arbTree (n `div` 4))-                                                 (arbTree (n `div` 2)))]--          sift x E a = sift1 x a-          sift x a E = let H1 x' a' = sift1 x a in H2 x' a' E-          sift x a b-              | x <= ma && x <= mb = H2 x a b-              | ma < x && ma <= mb = H2 ma (siftInto x a) b-              | otherwise          = H2 mb a (siftInto x b)-            where ma = minElem a-                  mb = minElem b--          sift1 x E = H1 x E-          sift1 x a-              | x <= ma   = H1 x a-              | otherwise = H1 ma (siftInto x a)-            where ma = minElem a--          siftInto x (H1 _ a) = sift1 x a-          siftInto x (H2 _ a b) = sift x a b-          siftInto _ E = error "LazyPairingHeap.arbitrary: bug!"--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where-  coarbitrary E = variant 0-  coarbitrary (H1 x a) = variant 1 . coarbitrary x . coarbitrary a-  coarbitrary (H2 x a b) =-      variant 2 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Semigroup (Heap a) where-    (<>) = union--instance (Ord a) => Monoid (Heap a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.LazyPairingHeap
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Lazy Paring Heaps
+--
+--   /References:/
+--
+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998.
+--   Section 6.5.
+
+module Data.Edison.Coll.LazyPairingHeap (
+    -- * Type of pairing heaps
+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',
+    fold1, fold1', filter, partition, strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,
+    unsafeMapMonotonic,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..),
+                                   Coll(..), OrdColl(..), toOrdList )
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.List (sort)
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.LazyPairingHeap"
+
+
+data Heap a = E
+            | H1 a (Heap a)
+            | H2 a !(Heap a) (Heap a)
+
+
+-- Invariants:
+--   * left child of H2 not empty
+structuralInvariant :: Heap a -> Bool
+structuralInvariant E = True
+structuralInvariant (H1 _ h) = structuralInvariant h
+structuralInvariant (H2 _ E _) = False
+structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r
+
+-- second arg is not empty
+-- not used!
+-- link E h = h
+-- link (H1 x b) a = H2 x a b
+-- link (H2 x a b) a' = H1 x (union (union a a') b)
+
+makeH2 :: a -> Heap a -> Heap a -> Heap a
+makeH2 x E xs = H1 x xs
+makeH2 x h xs = H2 x h xs
+
+empty :: Heap a
+empty = E
+
+singleton :: a -> Heap a
+singleton x = H1 x E
+
+insert :: Ord a => a -> Heap a -> Heap a
+insert x E = H1 x E
+insert x h@(H1 y b)
+  | x <= y    = H1 x h
+  | otherwise = H2 y (H1 x E) b
+insert x h@(H2 y a b)
+  | x <= y    = H1 x h
+  | otherwise = H1 y (union (insert x a) b)
+
+union :: Ord a => Heap a -> Heap a -> Heap a
+union E h = h
+union hx@(H1 _ _) E = hx
+union hx@(H1 x xs) hy@(H1 y ys)
+  | x <= y    = H2 x hy xs
+  | otherwise = H2 y hx ys
+union hx@(H1 x xs) hy@(H2 y a ys)
+  | x <= y    = H2 x hy xs
+  | otherwise = H1 y (union (union hx a) ys)
+union hx@(H2 _ _ _) E = hx
+union hx@(H2 x a xs) hy@(H1 y ys)
+  | x <= y    = H1 x (union (union hy a) xs)
+  | otherwise = H2 y hx ys
+union hx@(H2 x a xs) hy@(H2 y b ys)
+  | x <= y    = H1 x (union (union hy a) xs)
+  | otherwise = H1 y (union (union hx b) ys)
+
+delete :: Ord a => a -> Heap a -> Heap a
+delete y h = case del h of Just h' -> h'
+                           Nothing -> h
+  where del E = Nothing
+        del (H1 x xs) =
+          case compare x y of
+            LT -> case del xs of
+                    Just ys -> Just (H1 x ys)
+                    Nothing -> Nothing
+            EQ -> Just xs
+            GT -> Nothing
+        del (H2 x a xs) =
+          case compare x y of
+            LT -> case del a of
+                    Just a' -> Just (makeH2 x a' xs)
+                    Nothing -> case del xs of
+                                 Just xs' -> Just (H2 x a xs')
+                                 Nothing -> Nothing
+            EQ -> Just (union a xs)
+            GT -> Nothing
+
+deleteAll :: Ord a => a -> Heap a -> Heap a
+deleteAll _ E = E
+deleteAll y h@(H1 x xs) =
+  case compare x y of
+    LT -> H1 x (deleteAll y xs)
+    EQ -> deleteAll y xs
+    GT -> h
+deleteAll y h@(H2 x a xs) =
+  case compare x y of
+    LT -> makeH2 x (deleteAll y a) (deleteAll y xs)
+    EQ -> union (deleteAll y a) (deleteAll y xs)
+    GT -> h
+
+deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+deleteSeq = delList . sort . S.toList
+  where delList [] h = h
+        delList (y:ys) h = del y ys h
+
+        del _ _ E = E
+        del y ys h@(H1 x xs) =
+          case compare x y of
+            LT -> H1 x (del y ys xs)
+            EQ -> delList ys xs
+            GT -> delList ys h
+        del y ys h@(H2 x a xs) =
+          case compare x y of
+            LT -> H1 x (del y ys (union a xs))
+            EQ -> delList ys (union a xs)
+            GT -> delList ys h
+        {-
+           could write the two GT cases as
+             delList (dropWhile (< x) ys) h
+           but this is only a win if we expect many of the ys
+           to be missing from the tree.  However, we expect most
+           of the ys to be present.
+        -}
+
+null :: Heap a -> Bool
+null E = True
+null _ = False
+
+size :: Heap a -> Int
+size E = 0
+size (H1 _ xs) = 1 + size xs
+size (H2 _ h xs) = 1 + size h + size xs
+
+member :: Ord a => a -> Heap a -> Bool
+member _ E = False
+member x (H1 y ys) =
+  case compare x y of
+    LT -> False
+    EQ -> True
+    GT -> member x ys
+member x (H2 y h ys) =
+  case compare x y of
+    LT -> False
+    EQ -> True
+    GT -> member x h || member x ys
+
+count :: Ord a => a -> Heap a -> Int
+count _ E = 0
+count x (H1 y ys) =
+  case compare x y of
+    LT -> 0
+    EQ -> 1 + count x ys
+    GT -> count x ys
+count x (H2 y h ys) =
+  case compare x y of
+    LT -> 0
+    EQ -> 1 + count x h + count x ys
+    GT -> count x h + count x ys
+
+deleteMin :: Ord a => Heap a -> Heap a
+deleteMin E = E
+deleteMin (H1 _ xs) = xs
+deleteMin (H2 _ h xs) = union h xs
+
+unsafeInsertMin :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMin = H1
+
+unsafeInsertMax :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMax x E = H1 x E
+unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys
+unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys)
+
+unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a
+unsafeAppend h E = h
+unsafeAppend E h = h
+unsafeAppend (H1 x xs) h = H2 x h xs
+unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs)
+
+filterLT :: Ord a => a -> Heap a -> Heap a
+filterLT _ E = E
+filterLT y (H1 x xs)
+  | x < y = H1 x (filterLT y xs)
+  | otherwise = E
+filterLT y (H2 x h xs)
+  | x < y = makeH2 x (filterLT y h) (filterLT y xs)
+  | otherwise = E
+
+filterLE :: Ord a => a -> Heap a -> Heap a
+filterLE _ E = E
+filterLE y (H1 x xs)
+  | x <= y = H1 x (filterLE y xs)
+  | otherwise = E
+filterLE y (H2 x h xs)
+  | x <= y = makeH2 x (filterLE y h) (filterLE y xs)
+  | otherwise = E
+
+filterGT :: Ord a => a -> Heap a -> Heap a
+filterGT y h = fgt h E
+  where fgt E rest = rest
+        fgt i@(H1 x xs) rest
+          | x > y = union i rest
+          | otherwise = fgt xs rest
+        fgt i@(H2 x a xs) rest
+          | x > y = union i rest
+          | otherwise = fgt a (fgt xs rest)
+
+filterGE :: Ord a => a -> Heap a -> Heap a
+filterGE y h = fge h E
+  where fge E rest = rest
+        fge i@(H1 x xs) rest
+          | x >= y = union i rest
+          | otherwise = fge xs rest
+        fge i@(H2 x a xs) rest
+          | x >= y = union i rest
+          | otherwise = fge a (fge xs rest)
+
+partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GE _ E = (E,E)
+partitionLT_GE y h@(H1 x xs)
+  | x < y = let (xs',xs'') = partitionLT_GE y xs
+            in (H1 x xs',xs'')
+  | otherwise = (E, h)
+partitionLT_GE y h@(H2 x a xs)
+  | x < y = let (a',a'') = partitionLT_GE y a
+                (xs',xs'') = partitionLT_GE y xs
+            in (makeH2 x a' xs',union a'' xs'')
+  | otherwise = (E, h)
+
+partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLE_GT _ E = (E,E)
+partitionLE_GT y h@(H1 x xs)
+  | x <= y = let (xs',xs'') = partitionLE_GT y xs
+             in (H1 x xs',xs'')
+  | otherwise = (E, h)
+partitionLE_GT y h@(H2 x a xs)
+  | x <= y = let (a',a'') = partitionLE_GT y a
+                 (xs',xs'') = partitionLE_GT y xs
+             in (makeH2 x a' xs',union a'' xs'')
+  | otherwise = (E, h)
+
+partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GT _ E = (E,E)
+partitionLT_GT y h@(H1 x xs) =
+  case compare x y of
+    LT -> let (xs',xs'') = partitionLT_GT y xs
+          in (H1 x xs',xs'')
+    EQ -> (E, filterGT y xs)
+    GT -> (E, h)
+partitionLT_GT y h@(H2 x a xs) =
+  case compare x y of
+    LT -> let (a',a'') = partitionLT_GT y a
+              (xs',xs'') = partitionLT_GT y xs
+          in (makeH2 x a' xs',union a'' xs'')
+    EQ -> (E, union (filterGT y a) (filterGT y xs))
+    GT -> (E, h)
+
+toSeq :: S.Sequence seq => Heap a -> seq a
+toSeq h = tol h S.empty
+  where tol E rest = rest
+        tol (H1 x xs) rest = S.lcons x (tol xs rest)
+        tol (H2 x i xs) rest = S.lcons x $ tol i $ tol xs rest
+
+fold :: (a -> b -> b) -> b -> Heap a -> b
+fold _ c E = c
+fold f c (H1 x xs) = f x (fold f c xs)
+fold f c (H2 x h xs) = f x (fold f (fold f c xs) h)
+
+fold' :: (a -> b -> b) -> b -> Heap a -> b
+fold' _ c E = c
+fold' f c (H1 x xs)   = c `seq` f x $! (fold' f c xs)
+fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h)
+
+
+fold1 :: (a -> a -> a) -> Heap a -> a
+fold1 _ E = error "LazyPairingHeap.fold1: empty heap"
+fold1 f (H1 x xs) = fold f x xs
+fold1 f (H2 x h xs) = fold f (fold f x xs) h
+
+fold1' :: (a -> a -> a) -> Heap a -> a
+fold1' _ E = error "LazyPairingHeap.fold1': empty heap"
+fold1' f (H1 x xs)   = fold' f x xs
+fold1' f (H2 x h xs) = fold' f (fold' f x xs) h
+
+
+filter :: Ord a => (a -> Bool) -> Heap a -> Heap a
+filter _ E = E
+filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs
+filter p (H2 x h xs) =
+  if p x then makeH2 x (filter p h) (filter p xs)
+         else union (filter p h) (filter p xs)
+
+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)
+partition _ E = (E, E)
+partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'')
+    where (xs',xs'') = partition p xs
+partition p (H2 x h xs) =
+  if p x then (makeH2 x h' xs', union h'' xs'')
+         else (union h' xs', makeH2 x h'' xs'')
+    where (h',h'') = partition p h
+          (xs',xs'') = partition p xs
+
+lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a
+lookupAll y h = look h S.empty
+  where look E rest = rest
+        look (H1 x xs) rest =
+          case compare x y of
+            LT -> look xs rest
+            EQ -> S.lcons x (look xs rest)
+            GT -> rest
+        look (H2 x i xs) rest =
+          case compare x y of
+            LT -> look i $ look xs rest
+            EQ -> S.lcons x $ look i $ look xs rest
+            GT -> rest
+
+minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+minView E = fail "LazyPairingHeap.minView: empty heap"
+minView (H1 x xs) = return (x,xs)
+minView (H2 x h xs) = return (x,union h xs)
+
+minElem :: Heap a -> a
+minElem E = error "LazyPairingHeap.minElem: empty heap"
+minElem (H1 x _) = x
+minElem (H2 x _ _) = x
+
+maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+maxView E = fail "LazyPairingHeap.maxView: empty heap"
+maxView xs = return (y,xs')
+  where (xs', y) = maxView' xs
+
+-- not exported
+maxView' :: (Ord a) => Heap a -> (Heap a, a)
+maxView' (H1 x E) = (E, x)
+maxView' (H1 x xs) = (H1 x xs', y)
+  where (xs', y) = maxView' xs
+maxView' (H2 x a E) = (H1 x a', y)
+  where (a', y) = maxView' a
+maxView' (H2 x a xs) =
+    if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z)
+  where (a', y) = maxView' a
+        (xs', z) = maxView' xs
+maxView' E = error "LazyPairingHeap.maxView': bug!"
+
+maxElem :: Ord a => Heap a -> a
+maxElem E = error "LazyPairingHeap.maxElem: empty heap"
+maxElem (H1 x E) = x
+maxElem (H1 _ xs) = maxElem xs
+maxElem (H2 _ h E) = maxElem h
+maxElem (H2 _ h xs) = max (maxElem h) (maxElem xs)
+
+foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr _ c E = c
+foldr f c (H1 x xs) = f x (foldr f c xs)
+foldr f c (H2 x h xs) = f x (foldr f c (union h xs))
+
+foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr' _ c E = c
+foldr' f c (H1 x xs)   = c `seq` f x $! (foldr' f c xs)
+foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs))
+
+foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl _ c E = c
+foldl f c (H1 x xs) = foldl f (f c x) xs
+foldl f c (H2 x h xs) = foldl f (f c x) (union h xs)
+
+foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl' _ c E = c
+foldl' f c (H1 x xs)   = c `seq` foldl' f (f c x) xs
+foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs)
+
+foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1 _ E = error "LazyPairingHeap.foldr1: empty heap"
+foldr1 _ (H1 x E) = x
+foldr1 f (H1 x xs) = f x (foldr1 f xs)
+foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs))
+
+foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1' _ E = error "LazyPairingHeap.foldr1': empty heap"
+foldr1' _ (H1 x E)    = x
+foldr1' f (H1 x xs)   = f x $! (foldr1' f xs)
+foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs))
+
+foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1 _ E = error "LazyPairingHeap.foldl1: empty heap"
+foldl1 f (H1 x xs) = foldl f x xs
+foldl1 f (H2 x h xs) = foldl f x (union h xs)
+
+foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1' _ E = error "LazyPairingHeap.foldl1': empty heap"
+foldl1' f (H1 x xs)   = foldl' f x xs
+foldl1' f (H2 x h xs) = foldl' f x (union h xs)
+
+unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b
+unsafeMapMonotonic = mapm
+  where mapm _ E = E
+        mapm f (H1 x xs) = H1 (f x) (mapm f xs)
+        mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs)
+
+
+strict :: Heap a -> Heap a
+strict h@E = h
+strict h@(H1 _ xs) = strict xs `seq` h
+strict h@(H2 _ h' xs) = strict h' `seq` strict xs `seq` h
+
+strictWith :: (a -> b) -> Heap a -> Heap a
+strictWith _ h@E = h
+strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h
+strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h
+
+
+-- the remaining functions all use default definitions
+
+fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+fromSeq = fromSeqUsingFoldr
+
+insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+insertSeq = insertSeqUsingFoldr
+
+unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a
+unionSeq = unionSeqUsingFoldl
+
+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin
+
+deleteMax :: Ord a => Heap a -> Heap a
+deleteMax = deleteMaxUsingMaxView
+
+lookup :: Ord a => a -> Heap a -> a
+lookup = lookupUsingLookupAll
+
+lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a
+lookupM = lookupMUsingLookupAll
+
+lookupWithDefault :: Ord a => a -> a -> Heap a -> a
+lookupWithDefault = lookupWithDefaultUsingLookupAll
+
+toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a
+toOrdSeq = toOrdSeqUsingFoldr
+
+-- instance declarations
+
+instance Ord a => C.CollX (Heap a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Heap a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Heap a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance Ord a => C.OrdColl (Heap a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;
+   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}
+
+instance Ord a => Eq (Heap a) where
+  xs == ys = C.toOrdList xs == C.toOrdList ys
+
+instance (Ord a, Show a) => Show (Heap a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Ord a, Read a) => Read (Heap a) where
+  readsPrec = readsPrecUsingFromList
+
+instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where
+  arbitrary = sized (\n -> arbTree n)
+    where arbTree 0 = return E
+          arbTree n =
+            frequency [(1, return E),
+                       (2, liftM2 sift1 arbitrary (arbTree (n - 1))),
+                       (3, liftM3 sift arbitrary (arbTree (n `div` 4))
+                                                 (arbTree (n `div` 2)))]
+
+          sift x E a = sift1 x a
+          sift x a E = case sift1 x a of
+            H1 x' a' -> H2 x' a' E
+            _ -> undefined
+          sift x a b
+              | x <= ma && x <= mb = H2 x a b
+              | ma < x && ma <= mb = H2 ma (siftInto x a) b
+              | otherwise          = H2 mb a (siftInto x b)
+            where ma = minElem a
+                  mb = minElem b
+
+          sift1 x E = H1 x E
+          sift1 x a
+              | x <= ma   = H1 x a
+              | otherwise = H1 ma (siftInto x a)
+            where ma = minElem a
+
+          siftInto x (H1 _ a) = sift1 x a
+          siftInto x (H2 _ a b) = sift x a b
+          siftInto _ E = error "LazyPairingHeap.arbitrary: bug!"
+
+instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (H1 x a) = variant (1 :: Int) . coarbitrary x . coarbitrary a
+  coarbitrary (H2 x a b) =
+      variant (2 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b
+
+instance (Ord a) => Semigroup (Heap a) where
+    (<>) = union
+
+instance (Ord a) => Monoid (Heap a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a) => Ord (Heap a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/LeftistHeap.hs view

@@ -1,496 +1,497 @@--- |---   Module      :  Data.Edison.Coll.LeftistHeap---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Leftist Heaps------   /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1.--module Data.Edison.Coll.LeftistHeap (-    -- * Type of leftist heaps-    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',-    fold1, fold1', filter, partition, strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,-    unsafeMapMonotonic,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..),-                                   unionList, toOrdList )-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.LeftistHeap"--data Heap a = E | L !Int !a !(Heap a) !(Heap a)---- invariants:---   * Heap ordered---   * Leftist; the rank of any left node is >= the---     rank of its right sibling.  The rank of a node---     is the length of its right spine.--structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant E = True-structuralInvariant t@(L i x _ _) =-    i == rank t && isMin x t && checkLeftist t-- where rank :: Heap a -> Int-       rank E = 0-       rank (L _ _ _ s) = (rank s) + 1--       isMin _ E = True-       isMin z (L _ y l r) = z <= y && (isMin y l) && (isMin y r)--       checkLeftist E = True-       checkLeftist (L _ _ l r) =-          rank l >= rank r && checkLeftist l && checkLeftist r--node :: a -> Heap a -> Heap a -> Heap a-node x a E = L 1 x a E-node x E b = L 1 x b E-node x a@(L m _ _ _) b@(L n _ _ _)-  | m <= n     = L (m + 1) x b a-  | otherwise  = L (n + 1) x a b--{--Note: when we want to recurse down both sides, and we have a choice,-recursing down the smaller side first will minimize stack usage.--For delete,deleteAll,filter,partition: could compute fringe and reduce-rather that rebuilding with union at every deleted node--}--empty :: Ord a => Heap a-empty = E--singleton :: Ord a => a -> Heap a-singleton x = L 1 x E E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = L 1 x E E-insert x h@(L _ y a b)-  | x <= y    = L 1 x h E-  | otherwise = node y a (insert x b)--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union h@(L _ x a b) h' = union' h x a b h'-  where union' i _ _ _ E = i-        union' hx z q e hy@(L _ y c d)-          | z <= y    = node z q (union' hy y c d e)-          | otherwise = node y c (union' hx z q e d)--{--union E h = h-union h E = h-union h1@(L _ x a b) h2@(L _ y c d)-  | x <= y    = node x a (union b h2)-  | otherwise = node y c (union h1 d)-    -- ??? optimize to catch fact that h1 or h2 is known to be L case?--}--delete :: Ord a => a -> Heap a -> Heap a-delete x h = case del h of-               Just h' -> h'-               Nothing -> h-  where del (L _ y a b) =-          case compare x y of-            LT -> Nothing-            EQ -> Just (union a b)-            GT -> case del b of-                    Just b' -> Just (node y a b')-                    Nothing -> case del a  of-                                 Just a' -> Just (node y a' b)-                                 Nothing -> Nothing-        del E = Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll x h@(L _ y a b) =-  case compare x y of-    LT -> h-    EQ -> union (deleteAll x a) (deleteAll x b)-    GT -> node y (deleteAll x a) (deleteAll x b)-deleteAll _ E = E--null :: Ord a => Heap a -> Bool-null E = True-null _ = False--size :: Ord a => Heap a -> Int-size h = sz h 0-  where sz E i = i-        sz (L _ _ a b) i = sz a (sz b (i + 1))--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (L _ y a b) =-  case compare x y of-    LT -> False-    EQ -> True-    GT -> member x b || member x a--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (L _ y a b) =-  case compare x y of-    LT -> 0-    EQ -> 1 + count x b + count x a-    GT -> count x b + count x a--toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toSeq h = tol h S.empty-  where tol E rest = rest-        tol (L _ x a b) rest = S.lcons x (tol b (tol a rest))--lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a-lookupM _ E = fail "LeftistHeap.lookupM: XXX"-lookupM x (L _ y a b) =-  case compare x y of-    LT -> fail "LeftistHeap.lookupM: XXX"-    EQ -> return y-    GT -> case lookupM x b `mplus` lookupM x a of-                Nothing -> fail "LeftistHeap.lookupM: XXX"-                Just q -> return q--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll x h = look h S.empty-  where look E ys = ys-        look (L _ y a b) ys =-          case compare x y of-            LT -> ys-            EQ -> S.lcons y (look b (look a ys))-            GT -> look b (look a ys)--fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold _ e E = e-fold f e (L _ x a b) = f x (fold f (fold f e a) b)--fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold' _ e E = e-fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 :: Ord a => (a -> a -> a) -> Heap a -> a-fold1 _ E = error "LeftistHeap.fold1: empty collection"-fold1 f (L _ x a b) = fold f (fold f x a) b--fold1' :: Ord a => (a -> a -> a) -> Heap a -> a-fold1' _ E = error "LeftistHeap.fold1': empty collection"-fold1' f (L _ x a b) = fold' f (fold' f x a) b---filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (L _ x a b)-    | p x = node x (filter p a) (filter p b)-    | otherwise = union (filter p a) (filter p b)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (L _ x a b)-    | p x = (node x a' b', union a'' b'')-    | otherwise = (union a' b', node x a'' b'')-  where (a', a'') = partition p a-        (b', b'') = partition p b---deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (L _ _ a b) = union a b--deleteMax :: Ord a => Heap a -> Heap a-deleteMax h = case maxView h of-                Nothing     -> E-                Just (_,h') -> h'--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin x h = L 1 x h E--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend E h = h-unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h)--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b)-filterLT _ _ = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b)-filterLE _ _ = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = C.unionList (collect h [])-  where collect E hs = hs-        collect h@(L _ x a b) hs-          | x > y = h : hs-          | otherwise = collect a (collect b hs)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = C.unionList (collect h [])-  where collect E hs = hs-        collect h@(L _ x a b) hs-          | x >= y = h : hs-          | otherwise = collect b (collect a hs)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(L _ x a b) hs-          | x >= y = (E, h:hs)-          | otherwise = let (a', hs') = collect a hs-                            (b', hs'') = collect b hs'-                        in (node x a' b', hs'')--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(L _ x a b) hs-          | x > y = (E, h:hs)-          | otherwise = let (a', hs') = collect a hs-                            (b', hs'') = collect b hs'-                        in (node x a' b', hs'')--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(L _ x a b) is =-          case compare x y of-            GT -> (E, h:is)-            EQ -> let (a', hs') = collect a is-                      (b', hs'') = collect b hs'-                  in (union a' b', hs'')-            LT -> let (a', hs') = collect a is-                      (b', hs'') = collect b hs'-                  in (node x a' b', hs'')--minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-minView E = fail "LeftistHeap.minView: empty collection"-minView (L _ x a b) = return (x, union a b)--minElem :: Ord a => Heap a -> a-minElem E = error "LeftistHeap.minElem: empty collection"-minElem (L _ x _ _) = x--maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-maxView E = fail "LeftistHeap.maxView: empty collection"-maxView (L _ x E _) = return (x, E)-maxView (L _ x a E) = return (y, L 1 x a' E)-  where Just (y,a') = maxView a-maxView (L _ x a b)-    | y >= z    = return (y, node x a' b)-    | otherwise = return (z, node x a b')-  where Just (y, a') = maxView a-        Just (z, b') = maxView b---- warning: maxView and maxElem may disagree if root is equal to max!--maxElem :: Ord a => Heap a -> a-maxElem E = error "LeftistHeap.maxElem: empty collection"-maxElem (L _ x E _) = x-maxElem (L _ _ a b) = findMax b (findLeaf a)-  where findMax E m = m-        findMax (L _ x E _) m-          | m >= x = m-          | otherwise = x-        findMax (L _ _ d c) m = findMax d (findMax c m)--        findLeaf E = error "LeftistHeap.maxElem: bug"-        findLeaf (L _ x E _) = x-        findLeaf (L _ _ y c) = findMax c (findLeaf y)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ e E = e-foldr f e (L _ x a b) = f x (foldr f e (union a b))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ e E = e-foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ e E = e-foldl f e (L _ x a b) = foldl f (f e x) (union a b)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ e E = e-foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "LeftistHeap.foldr1: empty collection"-foldr1 _ (L _ x E _) = x-foldr1 f (L _ x a b) = f x (foldr1 f (union a b))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "LeftistHeap.foldr1': empty collection"-foldr1' _ (L _ x E _) = x-foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "LeftistHeap.foldl1: empty collection"-foldl1 f (L _ x a b) = foldl f x (union a b)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "LeftistHeap.foldl1: empty collection"-foldl1' f (L _ x a b) = foldl' f x (union a b)--{- ???? -}-unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a-unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (L i x a b) =-  L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)----- all fields are already fully strict!-strict :: Heap a -> Heap a-strict h = h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(L _ x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingUnionSeq--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingUnion--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingReduce--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = deleteSeqUsingDelete--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupM--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr----- instance declarations--instance Ord a => C.CollX (Heap a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;-   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where-  xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where-  showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where-  readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where-  arbitrary = sized (\n -> arbTree n)-    where arbTree 0 = return E-          arbTree n =-            frequency [(1, return E),-                       (4, liftM3 snode arbitrary (arbTree (n `div` 2))-                                                  (arbTree (n `div` 4)))]--          snode x a b = sift (node x a b)--          sift E = E-          sift t@(L _ x a E)-            | a == E || x <= minElem a = t-          sift (L r x (L r' y a b) E) =-                L r y (sift (L r' x a b)) E-          sift t@(L _ x a b)-            | x <= minElem a && x <= minElem b = t-          sift (L r x (L r' y a b) c)-            | y <= minElem c =-                L r y (sift (L r' x a b)) c-          sift (L r x a (L r' y b c)) =-                L r y a (sift (L r' x b c))-          sift _ = error "LeftistHeap.arbitrary: bug!"--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where-  coarbitrary E = variant 0-  coarbitrary (L _ x a b) =-      variant 1 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Semigroup (Heap a) where-    (<>) = union--instance (Ord a) => Monoid (Heap a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.LeftistHeap
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Leftist Heaps
+--
+--   /References:/
+--
+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1.
+
+module Data.Edison.Coll.LeftistHeap (
+    -- * Type of leftist heaps
+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',
+    fold1, fold1', filter, partition, strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,
+    unsafeMapMonotonic,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..),
+                                   unionList, toOrdList )
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.Maybe (fromJust)
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.LeftistHeap"
+
+data Heap a = E | L !Int !a !(Heap a) !(Heap a)
+
+-- invariants:
+--   * Heap ordered
+--   * Leftist; the rank of any left node is >= the
+--     rank of its right sibling.  The rank of a node
+--     is the length of its right spine.
+
+structuralInvariant :: Ord a => Heap a -> Bool
+structuralInvariant E = True
+structuralInvariant t@(L i x _ _) =
+    i == rank t && isMin x t && checkLeftist t
+
+ where rank :: Heap a -> Int
+       rank E = 0
+       rank (L _ _ _ s) = (rank s) + 1
+
+       isMin _ E = True
+       isMin z (L _ y l r) = z <= y && (isMin y l) && (isMin y r)
+
+       checkLeftist E = True
+       checkLeftist (L _ _ l r) =
+          rank l >= rank r && checkLeftist l && checkLeftist r
+
+node :: a -> Heap a -> Heap a -> Heap a
+node x a E = L 1 x a E
+node x E b = L 1 x b E
+node x a@(L m _ _ _) b@(L n _ _ _)
+  | m <= n     = L (m + 1) x b a
+  | otherwise  = L (n + 1) x a b
+
+{-
+Note: when we want to recurse down both sides, and we have a choice,
+recursing down the smaller side first will minimize stack usage.
+
+For delete,deleteAll,filter,partition: could compute fringe and reduce
+rather that rebuilding with union at every deleted node
+-}
+
+empty :: Ord a => Heap a
+empty = E
+
+singleton :: Ord a => a -> Heap a
+singleton x = L 1 x E E
+
+insert :: Ord a => a -> Heap a -> Heap a
+insert x E = L 1 x E E
+insert x h@(L _ y a b)
+  | x <= y    = L 1 x h E
+  | otherwise = node y a (insert x b)
+
+union :: Ord a => Heap a -> Heap a -> Heap a
+union E h = h
+union h@(L _ x a b) h' = union' h x a b h'
+  where union' i _ _ _ E = i
+        union' hx z q e hy@(L _ y c d)
+          | z <= y    = node z q (union' hy y c d e)
+          | otherwise = node y c (union' hx z q e d)
+
+{-
+union E h = h
+union h E = h
+union h1@(L _ x a b) h2@(L _ y c d)
+  | x <= y    = node x a (union b h2)
+  | otherwise = node y c (union h1 d)
+    -- ??? optimize to catch fact that h1 or h2 is known to be L case?
+-}
+
+delete :: Ord a => a -> Heap a -> Heap a
+delete x h = case del h of
+               Just h' -> h'
+               Nothing -> h
+  where del (L _ y a b) =
+          case compare x y of
+            LT -> Nothing
+            EQ -> Just (union a b)
+            GT -> case del b of
+                    Just b' -> Just (node y a b')
+                    Nothing -> case del a  of
+                                 Just a' -> Just (node y a' b)
+                                 Nothing -> Nothing
+        del E = Nothing
+
+deleteAll :: Ord a => a -> Heap a -> Heap a
+deleteAll x h@(L _ y a b) =
+  case compare x y of
+    LT -> h
+    EQ -> union (deleteAll x a) (deleteAll x b)
+    GT -> node y (deleteAll x a) (deleteAll x b)
+deleteAll _ E = E
+
+null :: Ord a => Heap a -> Bool
+null E = True
+null _ = False
+
+size :: Ord a => Heap a -> Int
+size h = sz h 0
+  where sz E i = i
+        sz (L _ _ a b) i = sz a (sz b (i + 1))
+
+member :: Ord a => a -> Heap a -> Bool
+member _ E = False
+member x (L _ y a b) =
+  case compare x y of
+    LT -> False
+    EQ -> True
+    GT -> member x b || member x a
+
+count :: Ord a => a -> Heap a -> Int
+count _ E = 0
+count x (L _ y a b) =
+  case compare x y of
+    LT -> 0
+    EQ -> 1 + count x b + count x a
+    GT -> count x b + count x a
+
+toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a
+toSeq h = tol h S.empty
+  where tol E rest = rest
+        tol (L _ x a b) rest = S.lcons x (tol b (tol a rest))
+
+lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a
+lookupM _ E = fail "LeftistHeap.lookupM: XXX"
+lookupM x (L _ y a b) =
+  case compare x y of
+    LT -> fail "LeftistHeap.lookupM: XXX"
+    EQ -> return y
+    GT -> case lookupM x b `mplus` lookupM x a of
+                Nothing -> fail "LeftistHeap.lookupM: XXX"
+                Just q -> return q
+
+lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a
+lookupAll x h = look h S.empty
+  where look E ys = ys
+        look (L _ y a b) ys =
+          case compare x y of
+            LT -> ys
+            EQ -> S.lcons y (look b (look a ys))
+            GT -> look b (look a ys)
+
+fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold _ e E = e
+fold f e (L _ x a b) = f x (fold f (fold f e a) b)
+
+fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold' _ e E = e
+fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b)
+
+fold1 :: Ord a => (a -> a -> a) -> Heap a -> a
+fold1 _ E = error "LeftistHeap.fold1: empty collection"
+fold1 f (L _ x a b) = fold f (fold f x a) b
+
+fold1' :: Ord a => (a -> a -> a) -> Heap a -> a
+fold1' _ E = error "LeftistHeap.fold1': empty collection"
+fold1' f (L _ x a b) = fold' f (fold' f x a) b
+
+
+filter :: Ord a => (a -> Bool) -> Heap a -> Heap a
+filter _ E = E
+filter p (L _ x a b)
+    | p x = node x (filter p a) (filter p b)
+    | otherwise = union (filter p a) (filter p b)
+
+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)
+partition _ E = (E, E)
+partition p (L _ x a b)
+    | p x = (node x a' b', union a'' b'')
+    | otherwise = (union a' b', node x a'' b'')
+  where (a', a'') = partition p a
+        (b', b'') = partition p b
+
+
+deleteMin :: Ord a => Heap a -> Heap a
+deleteMin E = E
+deleteMin (L _ _ a b) = union a b
+
+deleteMax :: Ord a => Heap a -> Heap a
+deleteMax h = case maxView h of
+                Nothing     -> E
+                Just (_,h') -> h'
+
+unsafeInsertMin :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMin x h = L 1 x h E
+
+unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a
+unsafeAppend E h = h
+unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h)
+
+filterLT :: Ord a => a -> Heap a -> Heap a
+filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b)
+filterLT _ _ = E
+
+filterLE :: Ord a => a -> Heap a -> Heap a
+filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b)
+filterLE _ _ = E
+
+filterGT :: Ord a => a -> Heap a -> Heap a
+filterGT y h = C.unionList (collect h [])
+  where collect E hs = hs
+        collect h@(L _ x a b) hs
+          | x > y = h : hs
+          | otherwise = collect a (collect b hs)
+
+filterGE :: Ord a => a -> Heap a -> Heap a
+filterGE y h = C.unionList (collect h [])
+  where collect E hs = hs
+        collect h@(L _ x a b) hs
+          | x >= y = h : hs
+          | otherwise = collect b (collect a hs)
+
+partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GE y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(L _ x a b) hs
+          | x >= y = (E, h:hs)
+          | otherwise = let (a', hs') = collect a hs
+                            (b', hs'') = collect b hs'
+                        in (node x a' b', hs'')
+
+partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLE_GT y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(L _ x a b) hs
+          | x > y = (E, h:hs)
+          | otherwise = let (a', hs') = collect a hs
+                            (b', hs'') = collect b hs'
+                        in (node x a' b', hs'')
+
+partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GT y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(L _ x a b) is =
+          case compare x y of
+            GT -> (E, h:is)
+            EQ -> let (a', hs') = collect a is
+                      (b', hs'') = collect b hs'
+                  in (union a' b', hs'')
+            LT -> let (a', hs') = collect a is
+                      (b', hs'') = collect b hs'
+                  in (node x a' b', hs'')
+
+minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+minView E = fail "LeftistHeap.minView: empty collection"
+minView (L _ x a b) = return (x, union a b)
+
+minElem :: Ord a => Heap a -> a
+minElem E = error "LeftistHeap.minElem: empty collection"
+minElem (L _ x _ _) = x
+
+maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+maxView E = fail "LeftistHeap.maxView: empty collection"
+maxView (L _ x E _) = return (x, E)
+maxView (L _ x a E) = return (y, L 1 x a' E)
+  where (y,a') = fromJust (maxView a)
+maxView (L _ x a b)
+    | y >= z    = return (y, node x a' b)
+    | otherwise = return (z, node x a b')
+  where (y, a') = fromJust (maxView a)
+        (z, b') = fromJust (maxView b)
+
+-- warning: maxView and maxElem may disagree if root is equal to max!
+
+maxElem :: Ord a => Heap a -> a
+maxElem E = error "LeftistHeap.maxElem: empty collection"
+maxElem (L _ x E _) = x
+maxElem (L _ _ a b) = findMax b (findLeaf a)
+  where findMax E m = m
+        findMax (L _ x E _) m
+          | m >= x = m
+          | otherwise = x
+        findMax (L _ _ d c) m = findMax d (findMax c m)
+
+        findLeaf E = error "LeftistHeap.maxElem: bug"
+        findLeaf (L _ x E _) = x
+        findLeaf (L _ _ y c) = findMax c (findLeaf y)
+
+foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr _ e E = e
+foldr f e (L _ x a b) = f x (foldr f e (union a b))
+
+foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr' _ e E = e
+foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b))
+
+foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl _ e E = e
+foldl f e (L _ x a b) = foldl f (f e x) (union a b)
+
+foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl' _ e E = e
+foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b)
+
+foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1 _ E = error "LeftistHeap.foldr1: empty collection"
+foldr1 _ (L _ x E _) = x
+foldr1 f (L _ x a b) = f x (foldr1 f (union a b))
+
+foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1' _ E = error "LeftistHeap.foldr1': empty collection"
+foldr1' _ (L _ x E _) = x
+foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b))
+
+foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1 _ E = error "LeftistHeap.foldl1: empty collection"
+foldl1 f (L _ x a b) = foldl f x (union a b)
+
+foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1' _ E = error "LeftistHeap.foldl1: empty collection"
+foldl1' f (L _ x a b) = foldl' f x (union a b)
+
+{- ???? -}
+unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a
+unsafeMapMonotonic _ E = E
+unsafeMapMonotonic f (L i x a b) =
+  L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)
+
+
+-- all fields are already fully strict!
+strict :: Heap a -> Heap a
+strict h = h
+
+strictWith :: (a -> b) -> Heap a -> Heap a
+strictWith _ h@E = h
+strictWith f h@(L _ x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h
+
+-- the remaining functions all use default definitions
+
+fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+fromSeq = fromSeqUsingUnionSeq
+
+insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+insertSeq = insertSeqUsingUnion
+
+unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a
+unionSeq = unionSeqUsingReduce
+
+deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+deleteSeq = deleteSeqUsingDelete
+
+lookup :: Ord a => a -> Heap a -> a
+lookup = lookupUsingLookupM
+
+lookupWithDefault :: Ord a => a -> a -> Heap a -> a
+lookupWithDefault = lookupWithDefaultUsingLookupM
+
+unsafeInsertMax :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend
+
+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin
+
+toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a
+toOrdSeq = toOrdSeqUsingFoldr
+
+
+-- instance declarations
+
+instance Ord a => C.CollX (Heap a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Heap a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Heap a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance Ord a => C.OrdColl (Heap a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;
+   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}
+
+instance Ord a => Eq (Heap a) where
+  xs == ys = C.toOrdList xs == C.toOrdList ys
+
+instance (Ord a, Show a) => Show (Heap a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Ord a, Read a) => Read (Heap a) where
+  readsPrec = readsPrecUsingFromList
+
+
+instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where
+  arbitrary = sized (\n -> arbTree n)
+    where arbTree 0 = return E
+          arbTree n =
+            frequency [(1, return E),
+                       (4, liftM3 snode arbitrary (arbTree (n `div` 2))
+                                                  (arbTree (n `div` 4)))]
+
+          snode x a b = sift (node x a b)
+
+          sift E = E
+          sift t@(L _ x a E)
+            | a == E || x <= minElem a = t
+          sift (L r x (L r' y a b) E) =
+                L r y (sift (L r' x a b)) E
+          sift t@(L _ x a b)
+            | x <= minElem a && x <= minElem b = t
+          sift (L r x (L r' y a b) c)
+            | y <= minElem c =
+                L r y (sift (L r' x a b)) c
+          sift (L r x a (L r' y b c)) =
+                L r y a (sift (L r' x b c))
+          sift _ = error "LeftistHeap.arbitrary: bug!"
+
+instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (L _ x a b) =
+      variant (1 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b
+
+instance (Ord a) => Semigroup (Heap a) where
+    (<>) = union
+
+instance (Ord a) => Monoid (Heap a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a) => Ord (Heap a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/MinHeap.hs view

@@ -1,410 +1,410 @@--- |---   Module      :  Data.Edison.Coll.MinHeap---   Copyright   :  Copyright (c) 1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   A generic adaptor for bags to keep the minimum element separately.--module Data.Edison.Coll.MinHeap (-    -- * Min heap adaptor type-    Min, -- instance of Coll/CollX, OrdColl/OrdCollX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',-    fold1, fold1', filter, partition, strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,-    unsafeMapMonotonic,--    -- * Other supported operations-    toColl,fromColl,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)-import Data.Monoid-import qualified Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck--data Min h a = E | M a h  deriving (Eq)--moduleName :: String-moduleName = "Data.Edison.Coll.MinHeap"--structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool-structuralInvariant E = True-structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h--empty     :: Min h a-singleton :: (C.CollX h a,Ord a) => a -> Min h a-fromSeq   :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a-insert    :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a-union     :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a-unionSeq  :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a-delete    :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a-null      :: Min h a -> Bool-size      :: C.CollX h a => Min h a -> Int-member    :: (C.CollX h a,Ord a) => a -> Min h a -> Bool-count     :: (C.CollX h a,Ord a) => a -> Min h a -> Int-strict    :: (C.CollX h a,Ord a) => Min h a -> Min h a--toSeq     :: (C.Coll h a,S.Sequence s) => Min h a -> s a-lookup    :: (C.Coll h a,Ord a) => a -> Min h a -> a-lookupM   :: (C.Coll h a, Ord a, Fail.MonadFail m) => a -> Min h a -> m a-lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a-lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a-fold      :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b-fold1     :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a-fold'     :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b-fold1'    :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a-filter    :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a-partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a)-strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a--deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a-deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a-unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a-unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a-filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)-partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)-partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)--minView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a)-minElem :: (C.OrdColl h a,Ord a) => Min h a -> a-maxView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a)-maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a-foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b-foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b-foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b-foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b-foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a-unsafeMapMonotonic :: (C.OrdColl h a,Ord a) =>-      (a -> a) -> Min h a -> Min h a--fromColl :: C.OrdColl h a => h -> Min h a-fromColl = fromPrim--toColl :: C.OrdColl h a => Min h a -> h-toColl = toPrim--fromPrim :: (C.OrdColl c a) => c -> Min c a-fromPrim xs = case C.minView xs of-                Nothing -> E-                Just (x, xs') -> M x xs'--toPrim :: (C.OrdCollX c a) => Min c a -> c-toPrim E = C.empty-toPrim (M x xs) = C.unsafeInsertMin x xs--empty = E-singleton x = M x C.empty--fromSeq = fromPrim . C.fromSeq--insert x E = M x C.empty-insert x (M y xs)-  | x <= y    = M x (C.unsafeInsertMin y xs)-  | otherwise = M y (C.insert x xs)--insertSeq xs E = fromSeq xs-insertSeq xs (M y ys) =-    case C.minView xs_ys of-      Nothing -> M y C.empty-      Just (x, rest)-          | x < y     -> M x (C.insert y rest)-          | otherwise -> M y xs_ys-  where xs_ys = C.insertSeq xs ys--union E ys = ys-union xs E = xs-union (M x xs) (M y ys)-  | x <= y    = M x (C.union xs (C.unsafeInsertMin y ys))-  | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys)--unionSeq = unionSeqUsingReduce--delete _ E = E-delete x m@(M y ys)-  | x > y     = M y (C.delete x ys)-  | x == y    = fromPrim ys-  | otherwise = m--deleteAll _ E = E-deleteAll x m@(M y ys)-  | x > y     = M y (C.deleteAll x ys)-  | x == y    = fromPrim (C.deleteAll x ys)-  | otherwise = m--deleteSeq = deleteSeqUsingDelete--null E = True-null (M _ _) = False--size E = 0-size (M _ xs) = 1 + C.size xs---member _ E = False-member x (M y ys)-  | x > y     = C.member x ys-  | otherwise = (x == y)--count _ E = 0-count x (M y ys)-  | x > y     = C.count x ys-  | x == y    = 1 + C.count x ys-  | otherwise = 0--toSeq E = S.empty-toSeq (M x xs) = S.lcons x (C.toSeq xs)--lookup x (M y ys)-  | x > y  = C.lookup x ys-  | x == y = y-lookup _ _ = error "MinHeap.lookup: empty heap"--lookupM x (M y ys)-  | x > y  = C.lookupM x ys-  | x == y = return y-lookupM _ _ = fail "lookupM.lookup: XXX"--lookupAll x (M y ys)-  | x > y  = C.lookupAll x ys-  | x == y = S.lcons y (C.lookupAll x ys)-lookupAll _ _ = S.empty--lookupWithDefault d x (M y ys)-  | x > y  = C.lookupWithDefault d x ys-  | x == y = y-lookupWithDefault d _ _ = d--fold _ e E = e-fold f e (M x xs) = f x (C.fold f e xs)--fold' _ e E = e-fold' f e (M x xs) = f x $! (C.fold' f e xs)--fold1 _ E = error "MinHeap.fold1: empty heap"-fold1 f (M x xs) = C.fold f x xs--fold1' _ E = error "MinHeap.fold1': empty heap"-fold1' f (M x xs) = C.fold' f x xs--filter _ E = E-filter p (M x xs)-  | p x       = M x (C.filter p xs)-  | otherwise = fromPrim (C.filter p xs)--partition _ E = (E, E)-partition p (M x xs)-    | p x       = (M x ys, fromPrim zs)-    | otherwise = (fromPrim ys, M x zs)-  where (ys,zs) = C.partition p xs--deleteMin E = E-deleteMin (M _ xs) = fromPrim xs--deleteMax E = E-deleteMax (M x xs)-  | C.null xs   = E-  | otherwise = M x (C.deleteMax xs)--unsafeInsertMin x xs = M x (toPrim xs)--unsafeInsertMax x E = M x C.empty-unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys)--unsafeFromOrdSeq xs =-  case S.lview xs of-    Nothing      -> E-    Just (x,xs') -> M x (C.unsafeFromOrdSeq xs')--unsafeAppend E ys = ys-unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys))--filterLT x (M y ys) | y < x  = M y (C.filterLT x ys)-filterLT _ _ = E--filterLE x (M y ys) | y <= x = M y (C.filterLE x ys)-filterLE _ _ = E--filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys)-filterGT _ h = h--filterGE x (M y ys) | y < x  = fromPrim (C.filterGE x ys)-filterGE _ h = h--partitionLT_GE x (M y ys)-  | y < x = (M y lows, fromPrim highs)-  where (lows,highs) = C.partitionLT_GE x ys-partitionLT_GE _ h = (E, h)--partitionLE_GT x (M y ys)-  | y <= x = (M y lows, fromPrim highs)-  where (lows,highs) = C.partitionLE_GT x ys-partitionLE_GT _ h = (E, h)--partitionLT_GT x (M y ys)-  | y < x  = let (lows,highs) = C.partitionLT_GT x ys-             in (M y lows, fromPrim highs)-  | y == x = (E, fromPrim (C.filterGT x ys))-partitionLT_GT _ h = (E, h)---minView E = fail "MinHeap.minView: empty heap"-minView (M x xs) = return (x, fromPrim xs)--minElem E = error "MinHeap.minElem: empty heap"-minElem (M x _) = x--maxView E = fail "MinHeap.maxView: empty heap"-maxView (M x xs) = case C.maxView xs of-                     Nothing     -> return (x, E)-                     Just (y,ys) -> return (y, M x ys)--maxElem E = error "MinHeap.minElem: empty heap"-maxElem (M x xs)-  | C.null xs   = x-  | otherwise = C.maxElem xs--foldr _ e E = e-foldr f e (M x xs) = f x (C.foldr f e xs)--foldr' _ e E = e-foldr' f e (M x xs) = f x $! (C.foldr' f e xs)--foldl _ e E = e-foldl f e (M x xs) = C.foldl f (f e x) xs--foldl' _ e E = e-foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs--foldr1 _ E = error "MinHeap.foldr1: empty heap"-foldr1 f (M x xs)-  | C.null xs   = x-  | otherwise = f x (C.foldr1 f xs)--foldr1' _ E = error "MinHeap.foldr1': empty heap"-foldr1' f (M x xs)-  | C.null xs = x-  | otherwise = f x $! (C.foldr1' f xs)--foldl1 _ E = error "MinHeap.foldl1: empty heap"-foldl1 f (M x xs) = C.foldl f x xs--foldl1' _ E = error "MinHeap.foldl1': empty heap"-foldl1' f (M x xs) = C.foldl' f x xs--toOrdSeq E = S.empty-toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs)--unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr--strict h@E = h-strict h@(M _ xs) = C.strict xs `seq` h--strictWith _ h@E = h-strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h----- instance declarations--instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;  foldr1' = foldr1';-   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic}---- instance Eq is derived--instance (C.OrdColl h a, Show h) => Show (Min h a) where-   showsPrec i xs rest-     | i == 0    = concat [    moduleName,".fromColl ",showsPrec 10 (toColl xs) rest]-     | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)]--instance (C.OrdColl h a, Read h) => Read (Min h a) where-   readsPrec _ xs = maybeParens p xs-       where p ys = tokenMatch (moduleName++".fromColl") ys-                      >>= readsPrec 10-                      >>= \(coll,rest) -> return (fromColl coll,rest)--instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where-  arbitrary = do xs <- arbitrary-                 x  <- arbitrary-                 i  <- arbitrary :: Gen Int-                 return (if C.null xs || x <= C.minElem xs then M x xs-                         else if odd i then M (C.minElem xs) xs-                                       else fromPrim xs)--instance (C.OrdColl h a,CoArbitrary h,CoArbitrary a) => CoArbitrary (Min h a) where-  coarbitrary E = variant 0-  coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs--instance (C.OrdColl h a) => SG.Semigroup (Min h a) where-    (<>) = union-instance (C.OrdColl h a) => Monoid (Min h a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Eq h, C.OrdColl h a) => Ord (Min h a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.MinHeap
+--   Copyright   :  Copyright (c) 1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   A generic adaptor for bags to keep the minimum element separately.
+
+module Data.Edison.Coll.MinHeap (
+    -- * Min heap adaptor type
+    Min, -- instance of Coll/CollX, OrdColl/OrdCollX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',
+    fold1, fold1', filter, partition, strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,
+    unsafeMapMonotonic,
+
+    -- * Other supported operations
+    toColl,fromColl,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Data.Edison.Coll as C
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)
+import Data.Monoid
+import qualified Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+data Min h a = E | M a h  deriving (Eq)
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.MinHeap"
+
+structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool
+structuralInvariant E = True
+structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h
+
+empty     :: Min h a
+singleton :: (C.CollX h a,Ord a) => a -> Min h a
+fromSeq   :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a
+insert    :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a
+insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a
+union     :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a
+unionSeq  :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a
+delete    :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a
+deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a
+deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a
+null      :: Min h a -> Bool
+size      :: C.CollX h a => Min h a -> Int
+member    :: (C.CollX h a,Ord a) => a -> Min h a -> Bool
+count     :: (C.CollX h a,Ord a) => a -> Min h a -> Int
+strict    :: (C.CollX h a,Ord a) => Min h a -> Min h a
+
+toSeq     :: (C.Coll h a,S.Sequence s) => Min h a -> s a
+lookup    :: (C.Coll h a,Ord a) => a -> Min h a -> a
+lookupM   :: (C.Coll h a, Ord a, Fail.MonadFail m) => a -> Min h a -> m a
+lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a
+lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a
+fold      :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b
+fold1     :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a
+fold'     :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b
+fold1'    :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a
+filter    :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a
+partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a)
+strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a
+
+deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a
+deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a
+unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a
+unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a
+unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a
+unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a
+filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a
+filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a
+filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a
+filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a
+partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)
+partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)
+partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)
+
+minView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a)
+minElem :: (C.OrdColl h a,Ord a) => Min h a -> a
+maxView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a)
+maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a
+foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b
+foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b
+foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a
+foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a
+foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b
+foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b
+foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a
+foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a
+toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a
+unsafeMapMonotonic :: (C.OrdColl h a,Ord a) =>
+      (a -> a) -> Min h a -> Min h a
+
+fromColl :: C.OrdColl h a => h -> Min h a
+fromColl = fromPrim
+
+toColl :: C.OrdColl h a => Min h a -> h
+toColl = toPrim
+
+fromPrim :: (C.OrdColl c a) => c -> Min c a
+fromPrim xs = case C.minView xs of
+                Nothing -> E
+                Just (x, xs') -> M x xs'
+
+toPrim :: (C.OrdCollX c a) => Min c a -> c
+toPrim E = C.empty
+toPrim (M x xs) = C.unsafeInsertMin x xs
+
+empty = E
+singleton x = M x C.empty
+
+fromSeq = fromPrim . C.fromSeq
+
+insert x E = M x C.empty
+insert x (M y xs)
+  | x <= y    = M x (C.unsafeInsertMin y xs)
+  | otherwise = M y (C.insert x xs)
+
+insertSeq xs E = fromSeq xs
+insertSeq xs (M y ys) =
+    case C.minView xs_ys of
+      Nothing -> M y C.empty
+      Just (x, rest)
+          | x < y     -> M x (C.insert y rest)
+          | otherwise -> M y xs_ys
+  where xs_ys = C.insertSeq xs ys
+
+union E ys = ys
+union xs E = xs
+union (M x xs) (M y ys)
+  | x <= y    = M x (C.union xs (C.unsafeInsertMin y ys))
+  | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys)
+
+unionSeq = unionSeqUsingReduce
+
+delete _ E = E
+delete x m@(M y ys)
+  | x > y     = M y (C.delete x ys)
+  | x == y    = fromPrim ys
+  | otherwise = m
+
+deleteAll _ E = E
+deleteAll x m@(M y ys)
+  | x > y     = M y (C.deleteAll x ys)
+  | x == y    = fromPrim (C.deleteAll x ys)
+  | otherwise = m
+
+deleteSeq = deleteSeqUsingDelete
+
+null E = True
+null (M _ _) = False
+
+size E = 0
+size (M _ xs) = 1 + C.size xs
+
+
+member _ E = False
+member x (M y ys)
+  | x > y     = C.member x ys
+  | otherwise = (x == y)
+
+count _ E = 0
+count x (M y ys)
+  | x > y     = C.count x ys
+  | x == y    = 1 + C.count x ys
+  | otherwise = 0
+
+toSeq E = S.empty
+toSeq (M x xs) = S.lcons x (C.toSeq xs)
+
+lookup x (M y ys)
+  | x > y  = C.lookup x ys
+  | x == y = y
+lookup _ _ = error "MinHeap.lookup: empty heap"
+
+lookupM x (M y ys)
+  | x > y  = C.lookupM x ys
+  | x == y = return y
+lookupM _ _ = fail "lookupM.lookup: XXX"
+
+lookupAll x (M y ys)
+  | x > y  = C.lookupAll x ys
+  | x == y = S.lcons y (C.lookupAll x ys)
+lookupAll _ _ = S.empty
+
+lookupWithDefault d x (M y ys)
+  | x > y  = C.lookupWithDefault d x ys
+  | x == y = y
+lookupWithDefault d _ _ = d
+
+fold _ e E = e
+fold f e (M x xs) = f x (C.fold f e xs)
+
+fold' _ e E = e
+fold' f e (M x xs) = f x $! (C.fold' f e xs)
+
+fold1 _ E = error "MinHeap.fold1: empty heap"
+fold1 f (M x xs) = C.fold f x xs
+
+fold1' _ E = error "MinHeap.fold1': empty heap"
+fold1' f (M x xs) = C.fold' f x xs
+
+filter _ E = E
+filter p (M x xs)
+  | p x       = M x (C.filter p xs)
+  | otherwise = fromPrim (C.filter p xs)
+
+partition _ E = (E, E)
+partition p (M x xs)
+    | p x       = (M x ys, fromPrim zs)
+    | otherwise = (fromPrim ys, M x zs)
+  where (ys,zs) = C.partition p xs
+
+deleteMin E = E
+deleteMin (M _ xs) = fromPrim xs
+
+deleteMax E = E
+deleteMax (M x xs)
+  | C.null xs   = E
+  | otherwise = M x (C.deleteMax xs)
+
+unsafeInsertMin x xs = M x (toPrim xs)
+
+unsafeInsertMax x E = M x C.empty
+unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys)
+
+unsafeFromOrdSeq xs =
+  case S.lview xs of
+    Nothing      -> E
+    Just (x,xs') -> M x (C.unsafeFromOrdSeq xs')
+
+unsafeAppend E ys = ys
+unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys))
+
+filterLT x (M y ys) | y < x  = M y (C.filterLT x ys)
+filterLT _ _ = E
+
+filterLE x (M y ys) | y <= x = M y (C.filterLE x ys)
+filterLE _ _ = E
+
+filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys)
+filterGT _ h = h
+
+filterGE x (M y ys) | y < x  = fromPrim (C.filterGE x ys)
+filterGE _ h = h
+
+partitionLT_GE x (M y ys)
+  | y < x = (M y lows, fromPrim highs)
+  where (lows,highs) = C.partitionLT_GE x ys
+partitionLT_GE _ h = (E, h)
+
+partitionLE_GT x (M y ys)
+  | y <= x = (M y lows, fromPrim highs)
+  where (lows,highs) = C.partitionLE_GT x ys
+partitionLE_GT _ h = (E, h)
+
+partitionLT_GT x (M y ys)
+  | y < x  = let (lows,highs) = C.partitionLT_GT x ys
+             in (M y lows, fromPrim highs)
+  | y == x = (E, fromPrim (C.filterGT x ys))
+partitionLT_GT _ h = (E, h)
+
+
+minView E = fail "MinHeap.minView: empty heap"
+minView (M x xs) = return (x, fromPrim xs)
+
+minElem E = error "MinHeap.minElem: empty heap"
+minElem (M x _) = x
+
+maxView E = fail "MinHeap.maxView: empty heap"
+maxView (M x xs) = case C.maxView xs of
+                     Nothing     -> return (x, E)
+                     Just (y,ys) -> return (y, M x ys)
+
+maxElem E = error "MinHeap.minElem: empty heap"
+maxElem (M x xs)
+  | C.null xs   = x
+  | otherwise = C.maxElem xs
+
+foldr _ e E = e
+foldr f e (M x xs) = f x (C.foldr f e xs)
+
+foldr' _ e E = e
+foldr' f e (M x xs) = f x $! (C.foldr' f e xs)
+
+foldl _ e E = e
+foldl f e (M x xs) = C.foldl f (f e x) xs
+
+foldl' _ e E = e
+foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs
+
+foldr1 _ E = error "MinHeap.foldr1: empty heap"
+foldr1 f (M x xs)
+  | C.null xs   = x
+  | otherwise = f x (C.foldr1 f xs)
+
+foldr1' _ E = error "MinHeap.foldr1': empty heap"
+foldr1' f (M x xs)
+  | C.null xs = x
+  | otherwise = f x $! (C.foldr1' f xs)
+
+foldl1 _ E = error "MinHeap.foldl1: empty heap"
+foldl1 f (M x xs) = C.foldl f x xs
+
+foldl1' _ E = error "MinHeap.foldl1': empty heap"
+foldl1' f (M x xs) = C.foldl' f x xs
+
+toOrdSeq E = S.empty
+toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs)
+
+unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr
+
+strict h@E = h
+strict h@(M _ xs) = C.strict xs `seq` h
+
+strictWith _ h@E = h
+strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h
+
+
+-- instance declarations
+
+instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;  foldr1' = foldr1';
+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic}
+
+-- instance Eq is derived
+
+instance (C.OrdColl h a, Show h) => Show (Min h a) where
+   showsPrec i xs rest
+     | i == 0    = concat [    moduleName,".fromColl ",showsPrec 10 (toColl xs) rest]
+     | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)]
+
+instance (C.OrdColl h a, Read h) => Read (Min h a) where
+   readsPrec _ xs = maybeParens p xs
+       where p ys = tokenMatch (moduleName++".fromColl") ys
+                      >>= readsPrec 10
+                      >>= \(coll,rest) -> return (fromColl coll,rest)
+
+instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where
+  arbitrary = do xs <- arbitrary
+                 x  <- arbitrary
+                 i  <- arbitrary :: Gen Int
+                 return (if C.null xs || x <= C.minElem xs then M x xs
+                         else if odd i then M (C.minElem xs) xs
+                                       else fromPrim xs)
+
+instance (C.OrdColl h a,CoArbitrary h,CoArbitrary a) => CoArbitrary (Min h a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (M x xs) = variant (1 :: Int) . coarbitrary x . coarbitrary xs
+
+instance (C.OrdColl h a) => SG.Semigroup (Min h a) where
+    (<>) = union
+instance (C.OrdColl h a) => Monoid (Min h a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Eq h, C.OrdColl h a) => Ord (Min h a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/SkewHeap.hs view

@@ -1,464 +1,465 @@--- |---   Module      :  Data.Edison.Coll.SkewHeap---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Skew heaps.------   /References:/------ * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\".---   /SIAM Journal on Computing/, 15(1):52-69, February 1986.--module Data.Edison.Coll.SkewHeap (-    -- * Type of skew heaps-    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',-    fold1, fold1', filter, partition, strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,-    unsafeMapMonotonic,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail--import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.SkewHeap"--data Heap a = E | T a (Heap a) (Heap a)---- invariants:---  * Heap order-structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant E = True-structuralInvariant t@(T x _ _) = isMin x t-  where isMin _ E = True-        isMin x (T y l r) = x <= y && isMin y l && isMin y r---{--For delete,deleteAll,filter,partition: could compute fringe and reduce-rather that rebuilding with union at every deleted node--}--empty :: Ord a => Heap a-empty = E--singleton :: Ord a => a -> Heap a-singleton x = T x E E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = T x E E-insert x h@(T y a b)-  | x <= y    = T x h E-  | otherwise = T y (insert x b) a--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union h@(T x a b) h' = union' h x a b h'-  where union' h _ _ _ E = h-        union' hx x a b hy@(T y c d)-          | x <= y    = T x (union' hy y c d b) a-          | otherwise = T y (union' hx x a b d) c--delete :: Ord a => a -> Heap a -> Heap a-delete x h = case del h of-               Just h' -> h'-               Nothing -> h-  where del (T y a b) =-          case compare x y of-            LT -> Nothing-            EQ -> Just (union a b)-            GT -> case del b of-                    Just b' -> Just (T y a b')-                    Nothing -> case del a  of-                                 Just a' -> Just (T y a' b)-                                 Nothing -> Nothing-        del E = Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll x h@(T y a b) =-  case compare x y of-    LT -> h-    EQ -> union (deleteAll x a) (deleteAll x b)-    GT -> T y (deleteAll x a) (deleteAll x b)-deleteAll _ E = E--null :: Ord a => Heap a -> Bool-null E = True-null _ = False--size :: Ord a => Heap a -> Int-size h = sz h 0-  where sz E i = i-        sz (T _ a b) i = sz a (sz b (i + 1))--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (T y a b) =-  case compare x y of-    LT -> False-    EQ -> True-    GT -> member x b || member x a--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (T y a b) =-  case compare x y of-    LT -> 0-    EQ -> 1 + count x b + count x a-    GT -> count x b + count x a--toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toSeq h = tol h S.empty-  where tol E rest = rest-        tol (T x a b) rest = S.lcons x (tol b (tol a rest))--lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a-lookupM _ E = fail "SkewHeap.lookupM: XXX"-lookupM x (T y a b) =-  case compare x y of-    LT -> fail "SkewHeap.lookupM: XXX"-    EQ -> return y-    GT -> case lookupM x b `mplus` lookupM x a of-                Nothing -> fail "SkewHeap.lookupM: XXX"-                Just x  -> return x--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll x h = look h S.empty-  where look E ys = ys-        look (T y a b) ys =-          case compare x y of-            LT -> ys-            EQ -> S.lcons y (look b (look a ys))-            GT -> look b (look a ys)--fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold _ e E = e-fold f e (T x a b) = f x (fold f (fold f e a) b)--fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold' _ e E = e-fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 :: Ord a => (a -> a -> a) -> Heap a -> a-fold1 _ E = error "SkewHeap.fold1: empty collection"-fold1 f (T x a b) = fold f (fold f x a) b--fold1' :: Ord a => (a -> a -> a) -> Heap a -> a-fold1' _ E = error "SkewHeap.fold1': empty collection"-fold1' f (T x a b) = fold' f (fold' f x a) b--filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (T x a b)-    | p x = T x (filter p a) (filter p b)-    | otherwise = union (filter p a) (filter p b)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (T x a b)-    | p x = (T x a' b', union a'' b'')-    | otherwise = (union a' b', T x a'' b'')-  where (a', a'') = partition p a-        (b', b'') = partition p b---deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (T _ a b) = union a b--deleteMax :: Ord a => Heap a -> Heap a-deleteMax h = case maxView h of-                Nothing     -> E-                Just (_,h') -> h'--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin x h = T x h E--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend E h = h-unsafeAppend (T x a b) h = T x (unsafeAppend b h) a--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b)-filterLT _ _ = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b)-filterLE _ _ = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = C.unionList (collect h [])-  where collect E hs = hs-        collect h@(T x a b) hs-          | x > y = h : hs-          | otherwise = collect a (collect b hs)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = C.unionList (collect h [])-  where collect E hs = hs-        collect h@(T x a b) hs-          | x >= y = h : hs-          | otherwise = collect b (collect a hs)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(T x a b) hs-          | x >= y = (E, h:hs)-          | otherwise = let (a', hs') = collect a hs-                            (b', hs'') = collect b hs'-                        in (T x a' b', hs'')--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(T x a b) hs-          | x > y = (E, h:hs)-          | otherwise = let (a', hs') = collect a hs-                            (b', hs'') = collect b hs'-                        in (T x a' b', hs'')--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT y h = (h', C.unionList hs)-  where (h', hs) = collect h []--        collect E hs = (E, hs)-        collect h@(T x a b) hs =-          case compare x y of-            GT -> (E, h:hs)-            EQ -> let (a', hs') = collect a hs-                      (b', hs'') = collect b hs'-                  in (union a' b', hs'')-            LT -> let (a', hs') = collect a hs-                      (b', hs'') = collect b hs'-                  in (T x a' b', hs'')--minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-minView E = fail "SkewHeap.minView: empty heap"-minView (T x a b) = return (x, union a b)--minElem :: Ord a => Heap a -> a-minElem E = error "SkewHeap.minElem: empty collection"-minElem (T x _ _) = x--maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-maxView E = fail "SkewHeap.maxView: empty heap"-maxView (T x E E) = return (x, E)-maxView (T x a E) = return (y, T x a' E)-  where Just (y, a') = maxView a-maxView (T x E a) = return (y, T x a' E)-  where Just (y, a') = maxView a-maxView (T x a b)-    | y >= z    = return (y, T x a' b)-    | otherwise = return (z, T x a b')-  where Just (y, a') = maxView a-        Just (z, b') = maxView b---- warning: maxView and maxElem may disagree if root is equal to max!--maxElem :: Ord a => Heap a -> a-maxElem E = error "SkewHeap.maxElem: empty collection"-maxElem (T x E E) = x-maxElem (T _ a E) = maxElem a-maxElem (T _ E a) = maxElem a-maxElem (T _ a b) = findMax b (findLeaf a)-  where findMax E m = m-        findMax (T x E E) m-          | m >= x = m-          | otherwise = x-        findMax (T _ a E) m = findMax a m-        findMax (T _ E a) m = findMax a m-        findMax (T _ a b) m = findMax a (findMax b m)--        findLeaf E = error "SkewHeap.maxElem: bug"-        findLeaf (T x E E) = x-        findLeaf (T _ a E) = findLeaf a-        findLeaf (T _ E a) = findLeaf a-        findLeaf (T _ a b) = findMax b (findLeaf a)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ e E = e-foldr f e (T x a b) = f x (foldr f e (union a b))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ e E = e-foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ e E = e-foldl f e (T x a b) = foldl f (f e x) (union a b)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ e E = e-foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "SkewHeap.foldr1: empty collection"-foldr1 _ (T x E E) = x-foldr1 f (T x a b) = f x (foldr1 f (union a b))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "SkewHeap.foldr1': empty collection"-foldr1' _ (T x E E) = x-foldr1' f (T x a b) = f x $! (foldr1' f (union a b))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "SkewHeap.foldl1: empty collection"-foldl1 f (T x a b) = foldl f x (union a b)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "SkewHeap.foldl1': empty collection"-foldl1' f (T x a b) = foldl' f x (union a b)--{- ???? -}-unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a-unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T x a b) =-  T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)---strict :: Heap a -> Heap a-strict h@E = h-strict h@(T _ l r) = strict l `seq` strict r `seq` h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingUnionSeq--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingUnion--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingReduce--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = deleteSeqUsingDelete--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupM--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr---- instance declarations--instance Ord a => C.CollX (Heap a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';-   foldl1  = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where-  xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where-  showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where-  readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where-  arbitrary = sized (\n -> arbTree n)-    where arbTree 0 = return E-          arbTree n =-            frequency [(1, return E),-                       (4, liftM3 sift arbitrary (arbTree (n `div` 2))-                                                 (arbTree (n `div` 4)))]--          sift x (T y a b) E-            | y < x = T y (sift x a b) E-          sift x E (T y a b)-            | y < x = T y E (sift x a b)-          sift x s@(T y a b) t@(T z c d)-            | y < x && y <= z = T y (sift x a b) t-            | z < x           = T z s (sift x c d)-          sift x a b = T x a b--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where-  coarbitrary E = variant 0-  coarbitrary (T x a b) =-      variant 1 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Semigroup (Heap a) where-    (<>) = union--instance (Ord a) => Monoid (Heap a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.SkewHeap
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Skew heaps.
+--
+--   /References:/
+--
+-- * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\".
+--   /SIAM Journal on Computing/, 15(1):52-69, February 1986.
+
+module Data.Edison.Coll.SkewHeap (
+    -- * Type of skew heaps
+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',
+    fold1, fold1', filter, partition, strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,
+    unsafeMapMonotonic,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Data.Edison.Coll as C
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.Maybe (fromJust)
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+
+import Test.QuickCheck
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.SkewHeap"
+
+data Heap a = E | T a (Heap a) (Heap a)
+
+-- invariants:
+--  * Heap order
+structuralInvariant :: Ord a => Heap a -> Bool
+structuralInvariant E = True
+structuralInvariant t@(T x _ _) = isMin x t
+  where isMin _ E = True
+        isMin x (T y l r) = x <= y && isMin y l && isMin y r
+
+
+{-
+For delete,deleteAll,filter,partition: could compute fringe and reduce
+rather that rebuilding with union at every deleted node
+-}
+
+empty :: Ord a => Heap a
+empty = E
+
+singleton :: Ord a => a -> Heap a
+singleton x = T x E E
+
+insert :: Ord a => a -> Heap a -> Heap a
+insert x E = T x E E
+insert x h@(T y a b)
+  | x <= y    = T x h E
+  | otherwise = T y (insert x b) a
+
+union :: Ord a => Heap a -> Heap a -> Heap a
+union E h = h
+union h@(T x a b) h' = union' h x a b h'
+  where union' h _ _ _ E = h
+        union' hx x a b hy@(T y c d)
+          | x <= y    = T x (union' hy y c d b) a
+          | otherwise = T y (union' hx x a b d) c
+
+delete :: Ord a => a -> Heap a -> Heap a
+delete x h = case del h of
+               Just h' -> h'
+               Nothing -> h
+  where del (T y a b) =
+          case compare x y of
+            LT -> Nothing
+            EQ -> Just (union a b)
+            GT -> case del b of
+                    Just b' -> Just (T y a b')
+                    Nothing -> case del a  of
+                                 Just a' -> Just (T y a' b)
+                                 Nothing -> Nothing
+        del E = Nothing
+
+deleteAll :: Ord a => a -> Heap a -> Heap a
+deleteAll x h@(T y a b) =
+  case compare x y of
+    LT -> h
+    EQ -> union (deleteAll x a) (deleteAll x b)
+    GT -> T y (deleteAll x a) (deleteAll x b)
+deleteAll _ E = E
+
+null :: Ord a => Heap a -> Bool
+null E = True
+null _ = False
+
+size :: Ord a => Heap a -> Int
+size h = sz h 0
+  where sz E i = i
+        sz (T _ a b) i = sz a (sz b (i + 1))
+
+member :: Ord a => a -> Heap a -> Bool
+member _ E = False
+member x (T y a b) =
+  case compare x y of
+    LT -> False
+    EQ -> True
+    GT -> member x b || member x a
+
+count :: Ord a => a -> Heap a -> Int
+count _ E = 0
+count x (T y a b) =
+  case compare x y of
+    LT -> 0
+    EQ -> 1 + count x b + count x a
+    GT -> count x b + count x a
+
+toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a
+toSeq h = tol h S.empty
+  where tol E rest = rest
+        tol (T x a b) rest = S.lcons x (tol b (tol a rest))
+
+lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a
+lookupM _ E = fail "SkewHeap.lookupM: XXX"
+lookupM x (T y a b) =
+  case compare x y of
+    LT -> fail "SkewHeap.lookupM: XXX"
+    EQ -> return y
+    GT -> case lookupM x b `mplus` lookupM x a of
+                Nothing -> fail "SkewHeap.lookupM: XXX"
+                Just x  -> return x
+
+lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a
+lookupAll x h = look h S.empty
+  where look E ys = ys
+        look (T y a b) ys =
+          case compare x y of
+            LT -> ys
+            EQ -> S.lcons y (look b (look a ys))
+            GT -> look b (look a ys)
+
+fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold _ e E = e
+fold f e (T x a b) = f x (fold f (fold f e a) b)
+
+fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold' _ e E = e
+fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b)
+
+fold1 :: Ord a => (a -> a -> a) -> Heap a -> a
+fold1 _ E = error "SkewHeap.fold1: empty collection"
+fold1 f (T x a b) = fold f (fold f x a) b
+
+fold1' :: Ord a => (a -> a -> a) -> Heap a -> a
+fold1' _ E = error "SkewHeap.fold1': empty collection"
+fold1' f (T x a b) = fold' f (fold' f x a) b
+
+filter :: Ord a => (a -> Bool) -> Heap a -> Heap a
+filter _ E = E
+filter p (T x a b)
+    | p x = T x (filter p a) (filter p b)
+    | otherwise = union (filter p a) (filter p b)
+
+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)
+partition _ E = (E, E)
+partition p (T x a b)
+    | p x = (T x a' b', union a'' b'')
+    | otherwise = (union a' b', T x a'' b'')
+  where (a', a'') = partition p a
+        (b', b'') = partition p b
+
+
+deleteMin :: Ord a => Heap a -> Heap a
+deleteMin E = E
+deleteMin (T _ a b) = union a b
+
+deleteMax :: Ord a => Heap a -> Heap a
+deleteMax h = case maxView h of
+                Nothing     -> E
+                Just (_,h') -> h'
+
+unsafeInsertMin :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMin x h = T x h E
+
+unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a
+unsafeAppend E h = h
+unsafeAppend (T x a b) h = T x (unsafeAppend b h) a
+
+filterLT :: Ord a => a -> Heap a -> Heap a
+filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b)
+filterLT _ _ = E
+
+filterLE :: Ord a => a -> Heap a -> Heap a
+filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b)
+filterLE _ _ = E
+
+filterGT :: Ord a => a -> Heap a -> Heap a
+filterGT y h = C.unionList (collect h [])
+  where collect E hs = hs
+        collect h@(T x a b) hs
+          | x > y = h : hs
+          | otherwise = collect a (collect b hs)
+
+filterGE :: Ord a => a -> Heap a -> Heap a
+filterGE y h = C.unionList (collect h [])
+  where collect E hs = hs
+        collect h@(T x a b) hs
+          | x >= y = h : hs
+          | otherwise = collect b (collect a hs)
+
+partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GE y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(T x a b) hs
+          | x >= y = (E, h:hs)
+          | otherwise = let (a', hs') = collect a hs
+                            (b', hs'') = collect b hs'
+                        in (T x a' b', hs'')
+
+partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLE_GT y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(T x a b) hs
+          | x > y = (E, h:hs)
+          | otherwise = let (a', hs') = collect a hs
+                            (b', hs'') = collect b hs'
+                        in (T x a' b', hs'')
+
+partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GT y h = (h', C.unionList hs)
+  where (h', hs) = collect h []
+
+        collect E hs = (E, hs)
+        collect h@(T x a b) hs =
+          case compare x y of
+            GT -> (E, h:hs)
+            EQ -> let (a', hs') = collect a hs
+                      (b', hs'') = collect b hs'
+                  in (union a' b', hs'')
+            LT -> let (a', hs') = collect a hs
+                      (b', hs'') = collect b hs'
+                  in (T x a' b', hs'')
+
+minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+minView E = fail "SkewHeap.minView: empty heap"
+minView (T x a b) = return (x, union a b)
+
+minElem :: Ord a => Heap a -> a
+minElem E = error "SkewHeap.minElem: empty collection"
+minElem (T x _ _) = x
+
+maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+maxView E = fail "SkewHeap.maxView: empty heap"
+maxView (T x E E) = return (x, E)
+maxView (T x a E) = return (y, T x a' E)
+  where (y, a') = fromJust (maxView a)
+maxView (T x E a) = return (y, T x a' E)
+  where (y, a') = fromJust (maxView a)
+maxView (T x a b)
+    | y >= z    = return (y, T x a' b)
+    | otherwise = return (z, T x a b')
+  where (y, a') = fromJust (maxView a)
+        (z, b') = fromJust (maxView b)
+
+-- warning: maxView and maxElem may disagree if root is equal to max!
+
+maxElem :: Ord a => Heap a -> a
+maxElem E = error "SkewHeap.maxElem: empty collection"
+maxElem (T x E E) = x
+maxElem (T _ a E) = maxElem a
+maxElem (T _ E a) = maxElem a
+maxElem (T _ a b) = findMax b (findLeaf a)
+  where findMax E m = m
+        findMax (T x E E) m
+          | m >= x = m
+          | otherwise = x
+        findMax (T _ a E) m = findMax a m
+        findMax (T _ E a) m = findMax a m
+        findMax (T _ a b) m = findMax a (findMax b m)
+
+        findLeaf E = error "SkewHeap.maxElem: bug"
+        findLeaf (T x E E) = x
+        findLeaf (T _ a E) = findLeaf a
+        findLeaf (T _ E a) = findLeaf a
+        findLeaf (T _ a b) = findMax b (findLeaf a)
+
+foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr _ e E = e
+foldr f e (T x a b) = f x (foldr f e (union a b))
+
+foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldr' _ e E = e
+foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b))
+
+foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl _ e E = e
+foldl f e (T x a b) = foldl f (f e x) (union a b)
+
+foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldl' _ e E = e
+foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b)
+
+foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1 _ E = error "SkewHeap.foldr1: empty collection"
+foldr1 _ (T x E E) = x
+foldr1 f (T x a b) = f x (foldr1 f (union a b))
+
+foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr1' _ E = error "SkewHeap.foldr1': empty collection"
+foldr1' _ (T x E E) = x
+foldr1' f (T x a b) = f x $! (foldr1' f (union a b))
+
+foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1 _ E = error "SkewHeap.foldl1: empty collection"
+foldl1 f (T x a b) = foldl f x (union a b)
+
+foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1' _ E = error "SkewHeap.foldl1': empty collection"
+foldl1' f (T x a b) = foldl' f x (union a b)
+
+{- ???? -}
+unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a
+unsafeMapMonotonic _ E = E
+unsafeMapMonotonic f (T x a b) =
+  T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)
+
+
+strict :: Heap a -> Heap a
+strict h@E = h
+strict h@(T _ l r) = strict l `seq` strict r `seq` h
+
+strictWith :: (a -> b) -> Heap a -> Heap a
+strictWith _ h@E = h
+strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h
+
+-- the remaining functions all use default definitions
+
+fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+fromSeq = fromSeqUsingUnionSeq
+
+insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+insertSeq = insertSeqUsingUnion
+
+unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a
+unionSeq = unionSeqUsingReduce
+
+deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a
+deleteSeq = deleteSeqUsingDelete
+
+lookup :: Ord a => a -> Heap a -> a
+lookup = lookupUsingLookupM
+
+lookupWithDefault :: Ord a => a -> a -> Heap a -> a
+lookupWithDefault = lookupWithDefaultUsingLookupM
+
+unsafeInsertMax :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend
+
+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a
+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin
+
+toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a
+toOrdSeq = toOrdSeqUsingFoldr
+
+-- instance declarations
+
+instance Ord a => C.CollX (Heap a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Heap a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Heap a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance Ord a => C.OrdColl (Heap a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';
+   foldl1  = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic}
+
+instance Ord a => Eq (Heap a) where
+  xs == ys = C.toOrdList xs == C.toOrdList ys
+
+instance (Ord a, Show a) => Show (Heap a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Ord a, Read a) => Read (Heap a) where
+  readsPrec = readsPrecUsingFromList
+
+
+instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where
+  arbitrary = sized (\n -> arbTree n)
+    where arbTree 0 = return E
+          arbTree n =
+            frequency [(1, return E),
+                       (4, liftM3 sift arbitrary (arbTree (n `div` 2))
+                                                 (arbTree (n `div` 4)))]
+
+          sift x (T y a b) E
+            | y < x = T y (sift x a b) E
+          sift x E (T y a b)
+            | y < x = T y E (sift x a b)
+          sift x s@(T y a b) t@(T z c d)
+            | y < x && y <= z = T y (sift x a b) t
+            | z < x           = T z s (sift x c d)
+          sift x a b = T x a b
+
+instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (T x a b) =
+      variant (1 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b
+
+instance (Ord a) => Semigroup (Heap a) where
+    (<>) = union
+
+instance (Ord a) => Monoid (Heap a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a) => Ord (Heap a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/SplayHeap.hs view

@@ -1,498 +1,498 @@--- |---   Module      :  Data.Edison.Coll.SplayHeap---   Copyright   :  Copyright (c) 1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Splay heaps.------   If 'minElem' is called frequently, then SplayHeap should---   be used in conjunction with "Data.Edison.Coll.MinHeap".------   /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.---   Section 5.4.--module Data.Edison.Coll.SplayHeap (-    -- * Type of splay heaps-    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',-    fold1, fold1', filter, partition, strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,-    unsafeMapMonotonic,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.SplayHeap"--data Heap a = E | T (Heap a) a (Heap a)---- invariants:---    * Binary Search Tree order (allowing duplicates)--structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant t = bounded Nothing Nothing t-   where bounded _ _ E = True-         bounded lo hi (T l x r)  = cmp_l lo x-                                 && cmp_r x hi-                                 && bounded lo (Just x) l-                                 && bounded (Just x) hi r--         cmp_l Nothing  _ = True-         cmp_l (Just x) y = x <= y--         cmp_r _ Nothing  = True-         cmp_r x (Just y) = x <= y---empty     :: Heap a-singleton :: a -> Heap a-fromSeq   :: (Ord a,S.Sequence s) => s a -> Heap a-insert    :: Ord a => a -> Heap a -> Heap a-insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a-union     :: Ord a => Heap a -> Heap a -> Heap a-unionSeq  :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a-delete    :: Ord a => a -> Heap a -> Heap a-deleteAll :: Ord a => a -> Heap a -> Heap a-deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a-null      :: Heap a -> Bool-size      :: Heap a -> Int-member    :: Ord a => a -> Heap a -> Bool-count     :: Ord a => a -> Heap a -> Int-strict    :: Heap a -> Heap a--toSeq     :: (Ord a, S.Sequence s) => Heap a -> s a-lookup    :: Ord a => a -> Heap a -> a-lookupM   :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a-lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a-lookupWithDefault :: Ord a => a -> a -> Heap a -> a-fold      :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold1     :: Ord a => (a -> a -> a) -> Heap a -> a-fold'     :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold1'    :: Ord a => (a -> a -> a) -> Heap a -> a-filter    :: Ord a => (a -> Bool) -> Heap a -> Heap a-partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-strictWith :: (a -> b) -> Heap a -> Heap a--deleteMin        :: Ord a => Heap a -> Heap a-deleteMax        :: Ord a => Heap a -> Heap a-unsafeInsertMin  :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax  :: Ord a => a -> Heap a -> Heap a-unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a-unsafeAppend     :: Ord a => Heap a -> Heap a -> Heap a-filterLT         :: Ord a => a -> Heap a -> Heap a-filterLE         :: Ord a => a -> Heap a -> Heap a-filterGT         :: Ord a => a -> Heap a -> Heap a-filterGE         :: Ord a => a -> Heap a -> Heap a-partitionLT_GE   :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)--minView  :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-minElem  :: Ord a => Heap a -> a-maxView  :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)-maxElem  :: Ord a => Heap a -> a-foldr    :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldl    :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldr1   :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1   :: Ord a => (a -> a -> a) -> Heap a -> a-foldr'   :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldl'   :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldr1'  :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1'  :: Ord a => (a -> a -> a) -> Heap a -> a-toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a--unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b--empty = E-singleton x = T E x E--insert x xs = T a x b-  where (a,b) = partitionLE_GT x xs--union E ys = ys-union (T a x b) ys = T (union c a) x (union d b)-  where (c,d) = partitionLE_GT x ys--delete x xs =-  let (a,b) = partitionLE_GT x xs-  in case maxView a of-       Nothing -> b-       Just (y, a')-         | x > y -> T a' y b-         | otherwise -> unsafeAppend a' b--deleteAll x xs = unsafeAppend a b-  where (a,b) = partitionLT_GT x xs--null E = True-null (T _ _ _) = False--size = sz 0-  where sz n E = n-        sz n (T a _ b) = sz (sz (1+n) a) b--member _ E = False-member x (T a y b) = if x < y then member x a else x==y || member x b--count = cnt 0-  where cnt n _ E = n-        cnt n x (T a y b)-          | x < y = cnt n x a-          | x > y = cnt n x b-          | otherwise = cnt (cnt (1+n) x a) x b--toSeq xs = tos xs S.empty-  where tos E rest = rest-        tos (T a x b) rest = S.lcons x (tos a (tos b rest))--lookup _ E = error "SplayHeap.lookup: empty heap"-lookup x (T a y b)-  | x < y     = lookup x a-  | x > y     = lookup x b-  | otherwise = y--lookupM _ E = fail "SplayHeap.lookup: empty heap"-lookupM x (T a y b)-  | x < y     = lookupM x a-  | x > y     = lookupM x b-  | otherwise = return y--lookupWithDefault d _ E = d-lookupWithDefault d x (T a y b)-  | x < y     = lookupWithDefault d x a-  | x > y     = lookupWithDefault d x b-  | otherwise = y--lookupAll x xs = look xs x S.empty-  where look E _ rest = rest-        look (T a y b) x rest-          | x < y     = look a x rest-          | x > y     = look b x rest-          | otherwise = look a x (S.lcons y (look b x rest))--fold _ e E = e-fold f e (T a x b) = f x (fold f (fold f e b) a)--fold' _ e E = e-fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a)--fold1 _ E = error "SplayHeap.fold1: empty heap"-fold1 f (T a x b) = fold f (fold f x b) a--fold1' _ E = error "SplayHeap.fold1': empty heap"-fold1' f (T a x b) = fold' f (fold' f x b) a--filter _ E = E-filter p (T a x b)-  | p x       = T (filter p a) x (filter p b)-  | otherwise = unsafeAppend (filter p a) (filter p b)--partition _ E = (E, E)-partition p (T a x b)-    | p x       = (T a0 x b0, unsafeAppend a1 b1)-    | otherwise = (unsafeAppend a0 b0, T a1 x b1)-  where (a0,a1) = partition p a-        (b0,b1) = partition p b--deleteMin E = E-deleteMin (T a x b) = del a x b-  where del E _ b = b-        del (T E _ b) y c = T b y c-        del (T (T a x b) y c) z d = T (del a x b) y (T c z d)--deleteMax E = E-deleteMax (T a x b) = del a x b-  where del a _ E = a-        del a x (T b _ E) = T a x b-        del a x (T b y (T c z d)) = T (T a x b) y (del c z d)--unsafeInsertMin x xs = T E x xs-unsafeInsertMax x xs = T xs x E--unsafeAppend a b = case maxView a of-                       Nothing      -> b-                       Just (x, a') -> T a' x b--filterLT _ E = E-filterLT k t@(T a x b) =-  if x >= k then filterLT k a-  else case b of-         E -> t-         T ba y bb ->-           if y >= k then T a x (filterLT k ba)-                     else T (T a x ba) y (filterLT k bb)--filterLE _ E = E-filterLE k t@(T a x b) =-  if x > k then filterLE k a-  else case b of-         E -> t-         T ba y bb ->-           if y > k then T a x (filterLE k ba)-                    else T (T a x ba) y (filterLE k bb)--filterGT _ E = E-filterGT k t@(T a x b) =-  if x <= k then filterGT k b-  else case a of-         E -> t-         T aa y ab ->-           if y <= k then T (filterGT k ab) x b-                     else T (filterGT k aa) y (T ab x b)--filterGE _ E = E-filterGE k t@(T a x b) =-  if x < k then filterGE k b-  else case a of-         E -> t-         T aa y ab ->-           if y < k then T (filterGE k ab) x b-                    else T (filterGE k aa) y (T ab x b)--partitionLT_GE _ E = (E,E)-partitionLT_GE k t@(T a x b) =-  if x >= k then-    case a of-      E -> (E,t)-      T aa y ab ->-        if y >= k then-          let (small,big) = partitionLT_GE k aa-          in (small, T big y (T ab x b))-        else-          let (small,big) = partitionLT_GE k ab-          in (T aa y small, T big x b)-  else-    case b of-      E -> (t,E)-      T ba y bb ->-        if y >= k then-          let (small,big) = partitionLT_GE k ba-          in (T a x small, T big y bb)-        else-          let (small,big) = partitionLT_GE k bb-          in (T (T a x ba) y small, big)--partitionLE_GT _ E = (E,E)-partitionLE_GT k t@(T a x b) =-  if x > k then-    case a of-      E -> (E,t)-      T aa y ab ->-        if y > k then-          let (small,big) = partitionLE_GT k aa-          in (small, T big y (T ab x b))-        else-          let (small,big) = partitionLE_GT k ab-          in (T aa y small, T big x b)-  else-    case b of-      E -> (t,E)-      T ba y bb ->-        if y > k then-          let (small,big) = partitionLE_GT k ba-          in (T a x small, T big y bb)-        else-          let (small,big) = partitionLE_GT k bb-          in (T (T a x ba) y small, big)----- could specialize calls to filterLT/filterGT-partitionLT_GT _ E = (E,E)-partitionLT_GT k t@(T a x b) =-  if x > k then-    case a of-      E -> (E,t)-      T aa y ab ->-        if y > k then-          let (small,big) = partitionLT_GT k aa-          in (small, T big y (T ab x b))-        else if y < k then-          let (small,big) = partitionLT_GT k ab-          in (T aa y small, T big x b)-        else (filterLT k aa, T (filterGT k ab) x b)-  else if x < k then-    case b of-      E -> (t,E)-      T ba y bb ->-        if y > k then-          let (small,big) = partitionLT_GT k ba-          in (T a x small, T big y bb)-        else if y < k then-          let (small,big) = partitionLT_GT k bb-          in (T (T a x ba) y small, big)-        else (T a x (filterLT k ba), filterGT k bb)-  else (filterLT k a, filterGT k b)--minView E = fail "SplayHeap.minView: empty heap"-minView (T a x b) = return (y, ys)-  where (y,ys) = minv a x b-        minv E x b = (x,b)-        minv (T E x b) y c = (x,T b y c)-        minv (T (T a x b) y c) z d = (w,T ab y (T c z d))-          where (w,ab) = minv a x b--minElem E = error "SplayHeap.minElem: empty heap"-minElem (T a x _) = minel a x-  where minel E x = x-        minel (T a x _) _ = minel a x---maxView E = fail "SplayHeap.maxView: empty heap"-maxView (T a x b) = return (y,ys)-  where (ys,y) = maxv a x b-        maxv a x E = (a,x)-        maxv a x (T b y E) = (T a x b,y)-        maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w)-          where (cd,w) = maxv c z d--maxElem E = error "SplayHeap.minElem: empty heap"-maxElem (T _ x b) = maxel x b-  where maxel x E = x-        maxel _ (T _ x b) = maxel x b--foldr _ e E = e-foldr f e (T a x b) = foldr f (f x (foldr f e b)) a--foldr' _ e E = e-foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a--foldl _ e E = e-foldl f e (T a x b) = foldl f (f (foldl f e a) x) b--foldl' _ e E = e-foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b--foldr1 _ E = error "SplayHeap.foldr1: empty heap"-foldr1 f (T a x b) = foldr f (myfold f x b) a-  where myfold _ x E = x-        myfold f x (T a y b) = f x (foldr f (myfold f y b) a)--foldr1' _ E = error "SplayHeap.foldr1': empty heap"-foldr1' f (T a x b) = foldr' f (myfold f x b) a-  where myfold _ x E = x-        myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a)--foldl1 _ E = error "SplayHeap.foldl1: empty heap"-foldl1 f (T a x b) = foldl f (myfold f a x) b-  where myfold _ E x = x-        myfold f (T a x b) y = f (foldl f (myfold f a x) b) y--foldl1' _ E = error "SplayHeap.foldl1': empty heap"-foldl1' f (T a x b) = foldl' f (myfold f a x) b-  where myfold _ E x = x-        myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y--toOrdSeq xs = tos xs S.empty-  where tos E rest = rest-        tos (T a x b) rest = tos a (S.lcons x (tos b rest))--unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T a x b) =-  T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)--strict h@E = h-strict h@(T l _ r) = strict l `seq` strict r `seq` h--strictWith _ h@E = h-strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use defaults--fromSeq = fromSeqUsingFoldr-insertSeq = insertSeqUsingFoldr-unionSeq = unionSeqUsingReduce-deleteSeq = deleteSeqUsingDelete-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin---- instance declarations--instance Ord a => C.CollX (Heap a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   strictWith = strictWith;-   filter = filter; partition = partition}--instance Ord a => C.OrdColl (Heap a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;-   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';-   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic}---instance Ord a => Eq (Heap a) where-  xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where-  showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where-  readsPrec = readsPrecUsingFromList--instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where-  arbitrary = do xs <- arbitrary-                 return (C.fromList xs)--instance (Ord a,CoArbitrary a) => CoArbitrary (Heap a) where-  coarbitrary E = variant 0-  coarbitrary (T a x b) =-    variant 1 . coarbitrary a . coarbitrary x . coarbitrary b--instance (Ord a) => Semigroup (Heap a) where-    (<>) = union-instance (Ord a) => Monoid (Heap a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.SplayHeap
+--   Copyright   :  Copyright (c) 1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Splay heaps.
+--
+--   If 'minElem' is called frequently, then SplayHeap should
+--   be used in conjunction with "Data.Edison.Coll.MinHeap".
+--
+--   /References:/
+--
+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998.
+--   Section 5.4.
+
+module Data.Edison.Coll.SplayHeap (
+    -- * Type of splay heaps
+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',
+    fold1, fold1', filter, partition, strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,
+    unsafeMapMonotonic,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Data.Edison.Coll as C
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+moduleName :: String
+moduleName = "Data.Edison.Coll.SplayHeap"
+
+data Heap a = E | T (Heap a) a (Heap a)
+
+-- invariants:
+--    * Binary Search Tree order (allowing duplicates)
+
+structuralInvariant :: Ord a => Heap a -> Bool
+structuralInvariant t = bounded Nothing Nothing t
+   where bounded _ _ E = True
+         bounded lo hi (T l x r)  = cmp_l lo x
+                                 && cmp_r x hi
+                                 && bounded lo (Just x) l
+                                 && bounded (Just x) hi r
+
+         cmp_l Nothing  _ = True
+         cmp_l (Just x) y = x <= y
+
+         cmp_r _ Nothing  = True
+         cmp_r x (Just y) = x <= y
+
+
+empty     :: Heap a
+singleton :: a -> Heap a
+fromSeq   :: (Ord a,S.Sequence s) => s a -> Heap a
+insert    :: Ord a => a -> Heap a -> Heap a
+insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a
+union     :: Ord a => Heap a -> Heap a -> Heap a
+unionSeq  :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a
+delete    :: Ord a => a -> Heap a -> Heap a
+deleteAll :: Ord a => a -> Heap a -> Heap a
+deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a
+null      :: Heap a -> Bool
+size      :: Heap a -> Int
+member    :: Ord a => a -> Heap a -> Bool
+count     :: Ord a => a -> Heap a -> Int
+strict    :: Heap a -> Heap a
+
+toSeq     :: (Ord a, S.Sequence s) => Heap a -> s a
+lookup    :: Ord a => a -> Heap a -> a
+lookupM   :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a
+lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a
+lookupWithDefault :: Ord a => a -> a -> Heap a -> a
+fold      :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold1     :: Ord a => (a -> a -> a) -> Heap a -> a
+fold'     :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+fold1'    :: Ord a => (a -> a -> a) -> Heap a -> a
+filter    :: Ord a => (a -> Bool) -> Heap a -> Heap a
+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)
+strictWith :: (a -> b) -> Heap a -> Heap a
+
+deleteMin        :: Ord a => Heap a -> Heap a
+deleteMax        :: Ord a => Heap a -> Heap a
+unsafeInsertMin  :: Ord a => a -> Heap a -> Heap a
+unsafeInsertMax  :: Ord a => a -> Heap a -> Heap a
+unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a
+unsafeAppend     :: Ord a => Heap a -> Heap a -> Heap a
+filterLT         :: Ord a => a -> Heap a -> Heap a
+filterLE         :: Ord a => a -> Heap a -> Heap a
+filterGT         :: Ord a => a -> Heap a -> Heap a
+filterGE         :: Ord a => a -> Heap a -> Heap a
+partitionLT_GE   :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLE_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)
+partitionLT_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)
+
+minView  :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+minElem  :: Ord a => Heap a -> a
+maxView  :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a)
+maxElem  :: Ord a => Heap a -> a
+foldr    :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldl    :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldr1   :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1   :: Ord a => (a -> a -> a) -> Heap a -> a
+foldr'   :: Ord a => (a -> b -> b) -> b -> Heap a -> b
+foldl'   :: Ord a => (b -> a -> b) -> b -> Heap a -> b
+foldr1'  :: Ord a => (a -> a -> a) -> Heap a -> a
+foldl1'  :: Ord a => (a -> a -> a) -> Heap a -> a
+toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a
+
+unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b
+
+empty = E
+singleton x = T E x E
+
+insert x xs = T a x b
+  where (a,b) = partitionLE_GT x xs
+
+union E ys = ys
+union (T a x b) ys = T (union c a) x (union d b)
+  where (c,d) = partitionLE_GT x ys
+
+delete x xs =
+  let (a,b) = partitionLE_GT x xs
+  in case maxView a of
+       Nothing -> b
+       Just (y, a')
+         | x > y -> T a' y b
+         | otherwise -> unsafeAppend a' b
+
+deleteAll x xs = unsafeAppend a b
+  where (a,b) = partitionLT_GT x xs
+
+null E = True
+null (T _ _ _) = False
+
+size = sz 0
+  where sz n E = n
+        sz n (T a _ b) = sz (sz (1+n) a) b
+
+member _ E = False
+member x (T a y b) = if x < y then member x a else x==y || member x b
+
+count = cnt 0
+  where cnt n _ E = n
+        cnt n x (T a y b)
+          | x < y = cnt n x a
+          | x > y = cnt n x b
+          | otherwise = cnt (cnt (1+n) x a) x b
+
+toSeq xs = tos xs S.empty
+  where tos E rest = rest
+        tos (T a x b) rest = S.lcons x (tos a (tos b rest))
+
+lookup _ E = error "SplayHeap.lookup: empty heap"
+lookup x (T a y b)
+  | x < y     = lookup x a
+  | x > y     = lookup x b
+  | otherwise = y
+
+lookupM _ E = fail "SplayHeap.lookup: empty heap"
+lookupM x (T a y b)
+  | x < y     = lookupM x a
+  | x > y     = lookupM x b
+  | otherwise = return y
+
+lookupWithDefault d _ E = d
+lookupWithDefault d x (T a y b)
+  | x < y     = lookupWithDefault d x a
+  | x > y     = lookupWithDefault d x b
+  | otherwise = y
+
+lookupAll x xs = look xs x S.empty
+  where look E _ rest = rest
+        look (T a y b) x rest
+          | x < y     = look a x rest
+          | x > y     = look b x rest
+          | otherwise = look a x (S.lcons y (look b x rest))
+
+fold _ e E = e
+fold f e (T a x b) = f x (fold f (fold f e b) a)
+
+fold' _ e E = e
+fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a)
+
+fold1 _ E = error "SplayHeap.fold1: empty heap"
+fold1 f (T a x b) = fold f (fold f x b) a
+
+fold1' _ E = error "SplayHeap.fold1': empty heap"
+fold1' f (T a x b) = fold' f (fold' f x b) a
+
+filter _ E = E
+filter p (T a x b)
+  | p x       = T (filter p a) x (filter p b)
+  | otherwise = unsafeAppend (filter p a) (filter p b)
+
+partition _ E = (E, E)
+partition p (T a x b)
+    | p x       = (T a0 x b0, unsafeAppend a1 b1)
+    | otherwise = (unsafeAppend a0 b0, T a1 x b1)
+  where (a0,a1) = partition p a
+        (b0,b1) = partition p b
+
+deleteMin E = E
+deleteMin (T a x b) = del a x b
+  where del E _ b = b
+        del (T E _ b) y c = T b y c
+        del (T (T a x b) y c) z d = T (del a x b) y (T c z d)
+
+deleteMax E = E
+deleteMax (T a x b) = del a x b
+  where del a _ E = a
+        del a x (T b _ E) = T a x b
+        del a x (T b y (T c z d)) = T (T a x b) y (del c z d)
+
+unsafeInsertMin x xs = T E x xs
+unsafeInsertMax x xs = T xs x E
+
+unsafeAppend a b = case maxView a of
+                       Nothing      -> b
+                       Just (x, a') -> T a' x b
+
+filterLT _ E = E
+filterLT k t@(T a x b) =
+  if x >= k then filterLT k a
+  else case b of
+         E -> t
+         T ba y bb ->
+           if y >= k then T a x (filterLT k ba)
+                     else T (T a x ba) y (filterLT k bb)
+
+filterLE _ E = E
+filterLE k t@(T a x b) =
+  if x > k then filterLE k a
+  else case b of
+         E -> t
+         T ba y bb ->
+           if y > k then T a x (filterLE k ba)
+                    else T (T a x ba) y (filterLE k bb)
+
+filterGT _ E = E
+filterGT k t@(T a x b) =
+  if x <= k then filterGT k b
+  else case a of
+         E -> t
+         T aa y ab ->
+           if y <= k then T (filterGT k ab) x b
+                     else T (filterGT k aa) y (T ab x b)
+
+filterGE _ E = E
+filterGE k t@(T a x b) =
+  if x < k then filterGE k b
+  else case a of
+         E -> t
+         T aa y ab ->
+           if y < k then T (filterGE k ab) x b
+                    else T (filterGE k aa) y (T ab x b)
+
+partitionLT_GE _ E = (E,E)
+partitionLT_GE k t@(T a x b) =
+  if x >= k then
+    case a of
+      E -> (E,t)
+      T aa y ab ->
+        if y >= k then
+          let (small,big) = partitionLT_GE k aa
+          in (small, T big y (T ab x b))
+        else
+          let (small,big) = partitionLT_GE k ab
+          in (T aa y small, T big x b)
+  else
+    case b of
+      E -> (t,E)
+      T ba y bb ->
+        if y >= k then
+          let (small,big) = partitionLT_GE k ba
+          in (T a x small, T big y bb)
+        else
+          let (small,big) = partitionLT_GE k bb
+          in (T (T a x ba) y small, big)
+
+partitionLE_GT _ E = (E,E)
+partitionLE_GT k t@(T a x b) =
+  if x > k then
+    case a of
+      E -> (E,t)
+      T aa y ab ->
+        if y > k then
+          let (small,big) = partitionLE_GT k aa
+          in (small, T big y (T ab x b))
+        else
+          let (small,big) = partitionLE_GT k ab
+          in (T aa y small, T big x b)
+  else
+    case b of
+      E -> (t,E)
+      T ba y bb ->
+        if y > k then
+          let (small,big) = partitionLE_GT k ba
+          in (T a x small, T big y bb)
+        else
+          let (small,big) = partitionLE_GT k bb
+          in (T (T a x ba) y small, big)
+
+
+-- could specialize calls to filterLT/filterGT
+partitionLT_GT _ E = (E,E)
+partitionLT_GT k t@(T a x b) =
+  if x > k then
+    case a of
+      E -> (E,t)
+      T aa y ab ->
+        if y > k then
+          let (small,big) = partitionLT_GT k aa
+          in (small, T big y (T ab x b))
+        else if y < k then
+          let (small,big) = partitionLT_GT k ab
+          in (T aa y small, T big x b)
+        else (filterLT k aa, T (filterGT k ab) x b)
+  else if x < k then
+    case b of
+      E -> (t,E)
+      T ba y bb ->
+        if y > k then
+          let (small,big) = partitionLT_GT k ba
+          in (T a x small, T big y bb)
+        else if y < k then
+          let (small,big) = partitionLT_GT k bb
+          in (T (T a x ba) y small, big)
+        else (T a x (filterLT k ba), filterGT k bb)
+  else (filterLT k a, filterGT k b)
+
+minView E = fail "SplayHeap.minView: empty heap"
+minView (T a x b) = return (y, ys)
+  where (y,ys) = minv a x b
+        minv E x b = (x,b)
+        minv (T E x b) y c = (x,T b y c)
+        minv (T (T a x b) y c) z d = (w,T ab y (T c z d))
+          where (w,ab) = minv a x b
+
+minElem E = error "SplayHeap.minElem: empty heap"
+minElem (T a x _) = minel a x
+  where minel E x = x
+        minel (T a x _) _ = minel a x
+
+
+maxView E = fail "SplayHeap.maxView: empty heap"
+maxView (T a x b) = return (y,ys)
+  where (ys,y) = maxv a x b
+        maxv a x E = (a,x)
+        maxv a x (T b y E) = (T a x b,y)
+        maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w)
+          where (cd,w) = maxv c z d
+
+maxElem E = error "SplayHeap.minElem: empty heap"
+maxElem (T _ x b) = maxel x b
+  where maxel x E = x
+        maxel _ (T _ x b) = maxel x b
+
+foldr _ e E = e
+foldr f e (T a x b) = foldr f (f x (foldr f e b)) a
+
+foldr' _ e E = e
+foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a
+
+foldl _ e E = e
+foldl f e (T a x b) = foldl f (f (foldl f e a) x) b
+
+foldl' _ e E = e
+foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b
+
+foldr1 _ E = error "SplayHeap.foldr1: empty heap"
+foldr1 f (T a x b) = foldr f (myfold f x b) a
+  where myfold _ x E = x
+        myfold f x (T a y b) = f x (foldr f (myfold f y b) a)
+
+foldr1' _ E = error "SplayHeap.foldr1': empty heap"
+foldr1' f (T a x b) = foldr' f (myfold f x b) a
+  where myfold _ x E = x
+        myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a)
+
+foldl1 _ E = error "SplayHeap.foldl1: empty heap"
+foldl1 f (T a x b) = foldl f (myfold f a x) b
+  where myfold _ E x = x
+        myfold f (T a x b) y = f (foldl f (myfold f a x) b) y
+
+foldl1' _ E = error "SplayHeap.foldl1': empty heap"
+foldl1' f (T a x b) = foldl' f (myfold f a x) b
+  where myfold _ E x = x
+        myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y
+
+toOrdSeq xs = tos xs S.empty
+  where tos E rest = rest
+        tos (T a x b) rest = tos a (S.lcons x (tos b rest))
+
+unsafeMapMonotonic _ E = E
+unsafeMapMonotonic f (T a x b) =
+  T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)
+
+strict h@E = h
+strict h@(T l _ r) = strict l `seq` strict r `seq` h
+
+strictWith _ h@E = h
+strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h
+
+-- the remaining functions all use defaults
+
+fromSeq = fromSeqUsingFoldr
+insertSeq = insertSeqUsingFoldr
+unionSeq = unionSeqUsingReduce
+deleteSeq = deleteSeqUsingDelete
+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin
+
+-- instance declarations
+
+instance Ord a => C.CollX (Heap a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Heap a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Heap a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   strictWith = strictWith;
+   filter = filter; partition = partition}
+
+instance Ord a => C.OrdColl (Heap a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;
+   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';
+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic}
+
+
+instance Ord a => Eq (Heap a) where
+  xs == ys = C.toOrdList xs == C.toOrdList ys
+
+instance (Ord a, Show a) => Show (Heap a) where
+  showsPrec = showsPrecUsingToList
+
+instance (Ord a, Read a) => Read (Heap a) where
+  readsPrec = readsPrecUsingFromList
+
+instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where
+  arbitrary = do xs <- arbitrary
+                 return (C.fromList xs)
+
+instance (Ord a,CoArbitrary a) => CoArbitrary (Heap a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (T a x b) =
+    variant (1 :: Int) . coarbitrary a . coarbitrary x . coarbitrary b
+
+instance (Ord a) => Semigroup (Heap a) where
+    (<>) = union
+instance (Ord a) => Monoid (Heap a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a) => Ord (Heap a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Coll/StandardSet.hs view

@@ -1,265 +1,265 @@--- |---   Module      :  Data.Edison.Coll---   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   The standard library "Data.Set" repackaged as an Edison collection.--module Data.Edison.Coll.StandardSet (-    -- * Set type-    Set,--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,--    -- * Coll operations-    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',-    fold1,fold1',filter,partition,strictWith,structuralInvariant,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,--    -- * SetX operations-    intersection,difference,symmetricDifference,properSubset,subset,--    -- * Set operations-    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,-    unionSeqWith,intersectionWith,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Prelude-import qualified Control.Monad.Fail as Fail-import qualified Data.List--import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Coll.Defaults-import Test.QuickCheck--import qualified Data.Set as DS---- signatures for exported functions-moduleName :: String-empty      :: Set a-singleton  :: a -> Set a-fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a-insert     :: Ord a => a -> Set a -> Set a-insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-union      :: Ord a => Set a -> Set a -> Set a-unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a-delete     :: Ord a => a -> Set a -> Set a-deleteAll  :: Ord a => a -> Set a -> Set a-deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-null       :: Set a -> Bool-size       :: Set a -> Int-member     :: Ord a => a -> Set a -> Bool-count      :: Ord a => a -> Set a -> Int-strict     :: Ord a => Set a -> Set a--toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a-lookup     :: Ord a => a -> Set a -> a-lookupM    :: (Ord a, Monad m, Fail.MonadFail m) => a -> Set a -> m a-lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a-lookupWithDefault :: Ord a => a -> a -> Set a  -> a-fold       :: (a -> b -> b) -> b -> Set a -> b-fold1      :: (a -> a -> a) -> Set a -> a-fold'      :: (a -> b -> b) -> b -> Set a -> b-fold1'     :: (a -> a -> a) -> Set a -> a-filter     :: Ord a => (a -> Bool) -> Set a -> Set a-partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)-strictWith :: Ord a => (a -> b) -> Set a -> Set a--deleteMin        :: Ord a => Set a -> Set a-deleteMax        :: Ord a => Set a -> Set a-unsafeInsertMin  :: Ord a => a -> Set a -> Set a-unsafeInsertMax  :: Ord a => a -> Set a -> Set a-unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-unsafeAppend     :: Ord a => Set a -> Set a -> Set a-filterLT         :: Ord a => a -> Set a -> Set a-filterLE         :: Ord a => a -> Set a -> Set a-filterGT         :: Ord a => a -> Set a -> Set a-filterGE         :: Ord a => a -> Set a -> Set a-partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)-partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)-partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)--minView       :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a)-minElem       :: Set a -> a-maxView       :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a)-maxElem       :: Set a -> a-foldr         :: (a -> b -> b) -> b -> Set a -> b-foldl         :: (b -> a -> b) -> b -> Set a -> b-foldr1        :: (a -> a -> a) -> Set a -> a-foldl1        :: (a -> a -> a) -> Set a -> a-foldr'        :: (a -> b -> b) -> b -> Set a -> b-foldl'        :: (b -> a -> b) -> b -> Set a -> b-foldr1'       :: (a -> a -> a) -> Set a -> a-foldl1'       :: (a -> a -> a) -> Set a -> a-toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a--intersection  :: Ord a => Set a -> Set a -> Set a-difference    :: Ord a => Set a -> Set a -> Set a-symmetricDifference :: Ord a => Set a -> Set a -> Set a-properSubset  :: Ord a => Set a -> Set a -> Bool-subset        :: Ord a => Set a -> Set a -> Bool--fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a-insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a-insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a-unionl       :: Ord a => Set a -> Set a -> Set a-unionr       :: Ord a => Set a -> Set a -> Set a-unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a-intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a--moduleName = "Data.Edison.Coll.StandardSet"--type Set = DS.Set--structuralInvariant :: Ord a => Set a -> Bool-structuralInvariant = DS.valid--empty              = DS.empty-singleton          = DS.singleton-fromSeq            = fromSeqUsingFoldr-insert             = DS.insert-insertSeq          = insertSeqUsingUnion-union              = DS.union-unionSeq se        = DS.unions $ S.toList se-delete             = DS.delete-deleteAll          = DS.delete -- by set property-deleteSeq          = deleteSeqUsingDelete-null               = DS.null-size               = DS.size-member             = DS.member-count              = countUsingMember-strict xs          = DS.fold (flip const) () xs `seq` xs--toSeq              = toSeqUsingFold-lookup el set      = DS.findMin (DS.intersection set (DS.singleton el))-lookupM            = lookupMUsingLookupAll-lookupAll el set   = toSeqUsingFold (DS.intersection set (DS.singleton el))-lookupWithDefault  = lookupWithDefaultUsingLookupAll-fold               = DS.fold-fold' f x xs       = L.foldl' (flip f) x (DS.toList xs)-fold1 f set        = let (x,s) = DS.deleteFindMin set in DS.fold f x s-fold1' f xs        = L.foldl1' (flip f) (DS.toList xs)-filter             = DS.filter-partition          = DS.partition-strictWith f xs    = DS.fold (\x z -> f x `seq` z) () xs `seq` xs--deleteMin          = DS.deleteMin-deleteMax          = DS.deleteMax-unsafeInsertMin    = DS.insert-unsafeInsertMax    = DS.insert-unsafeFromOrdSeq   = DS.fromDistinctAscList . S.toList-unsafeAppend       = DS.union-filterLT x         = fst . DS.split x-filterLE x         = DS.filter (<=x)-filterGT x         = snd . DS.split x-filterGE x         = DS.filter (>=x)-partitionLT_GE x   = DS.partition (<x)-partitionLE_GT x   = DS.partition (<=x)-partitionLT_GT     = DS.split--minView set        = if DS.null set-                        then fail (moduleName ++ ".minView: failed")-                        else return (DS.deleteFindMin set)-minElem            = DS.findMin--maxView set        = if DS.null set-                        then fail (moduleName ++ ".maxView: failed")-                        else return (DS.deleteFindMax set)-maxElem            = DS.findMax--foldr   f x set     = L.foldr   f x (DS.toAscList set)-foldr'  f x set     = L.foldr'  f x (DS.toAscList set)-foldr1  f   set     = L.foldr1  f   (DS.toAscList set)-foldr1' f   set     = L.foldr1' f   (DS.toAscList set)-foldl   f x set     = L.foldl   f x (DS.toAscList set)-foldl'  f x set     = L.foldl'  f x (DS.toAscList set)-foldl1  f   set     = L.foldl1  f   (DS.toAscList set)-foldl1' f   set     = L.foldl1' f   (DS.toAscList set)--toOrdSeq           = S.fromList . DS.toAscList--intersection       = DS.intersection-difference         = DS.difference-symmetricDifference = symmetricDifferenceUsingDifference-properSubset       = DS.isProperSubsetOf-subset             = DS.isSubsetOf--fromSeqWith        = fromSeqWithUsingInsertWith-insertWith f x set = case lookupM x set of-                        Nothing -> DS.insert x set-                        Just x' -> DS.insert (f x x') set-insertSeqWith      = insertSeqWithUsingInsertWith-unionl             = DS.union-unionr             = flip DS.union-unionWith          = unionWithUsingOrdLists-unionSeqWith       = unionSeqWithUsingReducer-intersectionWith   = intersectionWithUsingOrdLists-unsafeMapMonotonic = DS.mapMonotonic----instance Ord a => C.CollX (Set a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Set a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Set a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Set a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;-   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';-   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic }--instance Ord a => C.SetX (Set a) a where-  {intersection = intersection; difference = difference;-   symmetricDifference = symmetricDifference;-   properSubset = properSubset; subset = subset}--instance Ord a => C.Set (Set a) a where-  {fromSeqWith = fromSeqWith; insertWith = insertWith;-   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;-   unionWith = unionWith; unionSeqWith = unionSeqWith;-   intersectionWith = intersectionWith}--instance Ord a => C.OrdSetX (Set a) a--instance Ord a => C.OrdSet (Set a) a+-- |
+--   Module      :  Data.Edison.Coll
+--   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   The standard library "Data.Set" repackaged as an Edison collection.
+
+module Data.Edison.Coll.StandardSet (
+    -- * Set type
+    Set,
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,
+
+    -- * Coll operations
+    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',
+    fold1,fold1',filter,partition,strictWith,structuralInvariant,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,
+
+    -- * SetX operations
+    intersection,difference,symmetricDifference,properSubset,subset,
+
+    -- * Set operations
+    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,
+    unionSeqWith,intersectionWith,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Prelude
+import qualified Control.Monad.Fail as Fail
+import qualified Data.List
+
+import qualified Data.Edison.Coll as C
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Coll.Defaults
+import Test.QuickCheck
+
+import qualified Data.Set as DS
+
+-- signatures for exported functions
+moduleName :: String
+empty      :: Set a
+singleton  :: a -> Set a
+fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a
+insert     :: Ord a => a -> Set a -> Set a
+insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a
+union      :: Ord a => Set a -> Set a -> Set a
+unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a
+delete     :: Ord a => a -> Set a -> Set a
+deleteAll  :: Ord a => a -> Set a -> Set a
+deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a
+null       :: Set a -> Bool
+size       :: Set a -> Int
+member     :: Ord a => a -> Set a -> Bool
+count      :: Ord a => a -> Set a -> Int
+strict     :: Ord a => Set a -> Set a
+
+toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a
+lookup     :: Ord a => a -> Set a -> a
+lookupM    :: (Ord a, Monad m, Fail.MonadFail m) => a -> Set a -> m a
+lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a
+lookupWithDefault :: Ord a => a -> a -> Set a  -> a
+fold       :: (a -> b -> b) -> b -> Set a -> b
+fold1      :: (a -> a -> a) -> Set a -> a
+fold'      :: (a -> b -> b) -> b -> Set a -> b
+fold1'     :: (a -> a -> a) -> Set a -> a
+filter     :: Ord a => (a -> Bool) -> Set a -> Set a
+partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)
+strictWith :: Ord a => (a -> b) -> Set a -> Set a
+
+deleteMin        :: Ord a => Set a -> Set a
+deleteMax        :: Ord a => Set a -> Set a
+unsafeInsertMin  :: Ord a => a -> Set a -> Set a
+unsafeInsertMax  :: Ord a => a -> Set a -> Set a
+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a
+unsafeAppend     :: Ord a => Set a -> Set a -> Set a
+filterLT         :: Ord a => a -> Set a -> Set a
+filterLE         :: Ord a => a -> Set a -> Set a
+filterGT         :: Ord a => a -> Set a -> Set a
+filterGE         :: Ord a => a -> Set a -> Set a
+partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)
+partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)
+partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)
+
+minView       :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a)
+minElem       :: Set a -> a
+maxView       :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a)
+maxElem       :: Set a -> a
+foldr         :: (a -> b -> b) -> b -> Set a -> b
+foldl         :: (b -> a -> b) -> b -> Set a -> b
+foldr1        :: (a -> a -> a) -> Set a -> a
+foldl1        :: (a -> a -> a) -> Set a -> a
+foldr'        :: (a -> b -> b) -> b -> Set a -> b
+foldl'        :: (b -> a -> b) -> b -> Set a -> b
+foldr1'       :: (a -> a -> a) -> Set a -> a
+foldl1'       :: (a -> a -> a) -> Set a -> a
+toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a
+
+intersection  :: Ord a => Set a -> Set a -> Set a
+difference    :: Ord a => Set a -> Set a -> Set a
+symmetricDifference :: Ord a => Set a -> Set a -> Set a
+properSubset  :: Ord a => Set a -> Set a -> Bool
+subset        :: Ord a => Set a -> Set a -> Bool
+
+fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a
+insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a
+insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a
+unionl       :: Ord a => Set a -> Set a -> Set a
+unionr       :: Ord a => Set a -> Set a -> Set a
+unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a
+unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a
+intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a
+unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a
+
+moduleName = "Data.Edison.Coll.StandardSet"
+
+type Set = DS.Set
+
+structuralInvariant :: Ord a => Set a -> Bool
+structuralInvariant = DS.valid
+
+empty              = DS.empty
+singleton          = DS.singleton
+fromSeq            = fromSeqUsingFoldr
+insert             = DS.insert
+insertSeq          = insertSeqUsingUnion
+union              = DS.union
+unionSeq se        = DS.unions $ S.toList se
+delete             = DS.delete
+deleteAll          = DS.delete -- by set property
+deleteSeq          = deleteSeqUsingDelete
+null               = DS.null
+size               = DS.size
+member             = DS.member
+count              = countUsingMember
+strict xs          = DS.fold (flip const) () xs `seq` xs
+
+toSeq              = toSeqUsingFold
+lookup el set      = DS.findMin (DS.intersection set (DS.singleton el))
+lookupM            = lookupMUsingLookupAll
+lookupAll el set   = toSeqUsingFold (DS.intersection set (DS.singleton el))
+lookupWithDefault  = lookupWithDefaultUsingLookupAll
+fold               = DS.fold
+fold' f x xs       = L.foldl' (flip f) x (DS.toList xs)
+fold1 f set        = let (x,s) = DS.deleteFindMin set in DS.fold f x s
+fold1' f xs        = L.foldl1' (flip f) (DS.toList xs)
+filter             = DS.filter
+partition          = DS.partition
+strictWith f xs    = DS.fold (\x z -> f x `seq` z) () xs `seq` xs
+
+deleteMin          = DS.deleteMin
+deleteMax          = DS.deleteMax
+unsafeInsertMin    = DS.insert
+unsafeInsertMax    = DS.insert
+unsafeFromOrdSeq   = DS.fromDistinctAscList . S.toList
+unsafeAppend       = DS.union
+filterLT x         = fst . DS.split x
+filterLE x         = DS.filter (<=x)
+filterGT x         = snd . DS.split x
+filterGE x         = DS.filter (>=x)
+partitionLT_GE x   = DS.partition (<x)
+partitionLE_GT x   = DS.partition (<=x)
+partitionLT_GT     = DS.split
+
+minView set        = if DS.null set
+                        then fail (moduleName ++ ".minView: failed")
+                        else return (DS.deleteFindMin set)
+minElem            = DS.findMin
+
+maxView set        = if DS.null set
+                        then fail (moduleName ++ ".maxView: failed")
+                        else return (DS.deleteFindMax set)
+maxElem            = DS.findMax
+
+foldr   f x set     = L.foldr   f x (DS.toAscList set)
+foldr'  f x set     = L.foldr'  f x (DS.toAscList set)
+foldr1  f   set     = L.foldr1  f   (DS.toAscList set)
+foldr1' f   set     = L.foldr1' f   (DS.toAscList set)
+foldl   f x set     = L.foldl   f x (DS.toAscList set)
+foldl'  f x set     = L.foldl'  f x (DS.toAscList set)
+foldl1  f   set     = L.foldl1  f   (DS.toAscList set)
+foldl1' f   set     = L.foldl1' f   (DS.toAscList set)
+
+toOrdSeq           = S.fromList . DS.toAscList
+
+intersection       = DS.intersection
+difference         = DS.difference
+symmetricDifference = symmetricDifferenceUsingDifference
+properSubset       = DS.isProperSubsetOf
+subset             = DS.isSubsetOf
+
+fromSeqWith        = fromSeqWithUsingInsertWith
+insertWith f x set = case lookupM x set of
+                        Nothing -> DS.insert x set
+                        Just x' -> DS.insert (f x x') set
+insertSeqWith      = insertSeqWithUsingInsertWith
+unionl             = DS.union
+unionr             = flip DS.union
+unionWith          = unionWithUsingOrdLists
+unionSeqWith       = unionSeqWithUsingReducer
+intersectionWith   = intersectionWithUsingOrdLists
+unsafeMapMonotonic = DS.mapMonotonic
+
+
+
+instance Ord a => C.CollX (Set a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Set a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Set a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance Ord a => C.OrdColl (Set a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;
+   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';
+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic }
+
+instance Ord a => C.SetX (Set a) a where
+  {intersection = intersection; difference = difference;
+   symmetricDifference = symmetricDifference;
+   properSubset = properSubset; subset = subset}
+
+instance Ord a => C.Set (Set a) a where
+  {fromSeqWith = fromSeqWith; insertWith = insertWith;
+   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;
+   unionWith = unionWith; unionSeqWith = unionSeqWith;
+   intersectionWith = intersectionWith}
+
+instance Ord a => C.OrdSetX (Set a) a
+
+instance Ord a => C.OrdSet (Set a) a

src/Data/Edison/Coll/UnbalancedSet.hs view

@@ -1,443 +1,444 @@--- |---   Module      :  Data.Edison.Coll.UnbalancedSet---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Sets implemented as unbalanced binary search trees.--module Data.Edison.Coll.UnbalancedSet (-    -- * Set type-    Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX--    -- * CollX operations-    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,-    deleteSeq,null,size,member,count,strict,structuralInvariant,--    -- * Coll operations-    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',-    fold1,fold1',filter,partition,strictWith,--    -- * OrdCollX operations-    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,-    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,-    partitionLE_GT,partitionLT_GT,--    -- * OrdColl operations-    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',-    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,--    -- * SetX operations-    intersection,difference,symmetricDifference,properSubset,subset,--    -- * Set operations-    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,-    unionSeqWith,intersectionWith,--    -- * Documentation-    moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)-import qualified Prelude-import qualified Control.Monad.Fail as Fail-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty      :: Set a-singleton  :: a -> Set a-fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a-insert     :: Ord a => a -> Set a -> Set a-insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-union      :: Ord a => Set a -> Set a -> Set a-unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a-delete     :: Ord a => a -> Set a -> Set a-deleteAll  :: Ord a => a -> Set a -> Set a-deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-null       :: Set a -> Bool-size       :: Set a -> Int-member     :: Ord a => a -> Set a -> Bool-count      :: Ord a => a -> Set a -> Int-strict     :: Set a -> Set a--toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a-lookup     :: Ord a => a -> Set a -> a-lookupM    :: (Ord a, Fail.MonadFail m) => a -> Set a -> m a-lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a-lookupWithDefault :: Ord a => a -> a -> Set a -> a-fold       :: (a -> b -> b) -> b -> Set a -> b-fold1      :: (a -> a -> a) -> Set a -> a-fold'      :: (a -> b -> b) -> b -> Set a -> b-fold1'     :: (a -> a -> a) -> Set a -> a-filter     :: Ord a => (a -> Bool) -> Set a -> Set a-partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)-strictWith :: (a -> b) -> Set a -> Set a--deleteMin        :: Ord a => Set a -> Set a-deleteMax        :: Ord a => Set a -> Set a-unsafeInsertMin  :: Ord a => a -> Set a -> Set a-unsafeInsertMax  :: Ord a => a -> Set a -> Set a-unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-unsafeAppend     :: Ord a => Set a -> Set a -> Set a-filterLT         :: Ord a => a -> Set a -> Set a-filterLE         :: Ord a => a -> Set a -> Set a-filterGT         :: Ord a => a -> Set a -> Set a-filterGE         :: Ord a => a -> Set a -> Set a-partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)-partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)-partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)--minView       :: (Fail.MonadFail m) => Set a -> m (a, Set a)-minElem       :: Set a -> a-maxView       :: (Fail.MonadFail m) => Set a -> m (a, Set a)-maxElem       :: Set a -> a-foldr         :: (a -> b -> b) -> b -> Set a -> b-foldl         :: (b -> a -> b) -> b -> Set a -> b-foldr1        :: (a -> a -> a) -> Set a -> a-foldl1        :: (a -> a -> a) -> Set a -> a-foldr'        :: (a -> b -> b) -> b -> Set a -> b-foldl'        :: (b -> a -> b) -> b -> Set a -> b-foldr1'       :: (a -> a -> a) -> Set a -> a-foldl1'       :: (a -> a -> a) -> Set a -> a-toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a--intersection  :: Ord a => Set a -> Set a -> Set a-difference    :: Ord a => Set a -> Set a -> Set a-symmetricDifference :: Ord a => Set a -> Set a -> Set a-properSubset  :: Ord a => Set a -> Set a -> Bool-subset        :: Ord a => Set a -> Set a -> Bool--fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a-insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a-insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a-unionl       :: Ord a => Set a -> Set a -> Set a-unionr       :: Ord a => Set a -> Set a -> Set a-unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a-intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a--moduleName = "Data.Edison.Coll.UnbalancedSet"--data Set a = E | T (Set a) a (Set a)---- invariants:---   * Binary Search Tree order-structuralInvariant :: Ord a => Set a -> Bool-structuralInvariant t = bounded Nothing Nothing t-   where bounded _ _ E = True-         bounded lo hi (T l x r)  = cmp_l lo x-                                 && cmp_r x hi-                                 && bounded lo (Just x) l-                                 && bounded (Just x) hi r--         cmp_l Nothing  _ = True-         cmp_l (Just x) y = x < y--         cmp_r _ Nothing  = True-         cmp_r x (Just y) = x < y----empty = E-singleton x = T E x E--insertWith c x = ins-  where ins E = T E x E-        ins (T a y b) =-          case compare x y of-            LT -> T (ins a) y b-            EQ -> T a (c x y) b-            GT -> T a y (ins b)--delete _ E = E-delete x (T a y b) =-  case compare x y of-    LT -> T (delete x a) y b-    EQ -> unsafeAppend a b-    GT -> T a y (delete x b)--null E = True-null (T _ _ _) = False--size t = sz t 0-  where sz E i = i-        sz (T a _ b) i = sz a (sz b (i+1))--member _ E = False-member x (T a y b) =-  case compare x y of-    LT -> member x a-    EQ -> True-    GT -> member x b--lookupM _ E = fail "UnbalancedSet.lookupM: XXX"-lookupM x (T a y b) =-  case compare x y of-    LT -> lookupM x a-    EQ -> return y-    GT -> lookupM x b--fold _ e E = e-fold f e (T a x b) = f x (fold f (fold f e a) b)--fold' _ e E = e-fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 _ E = error "UnbalancedSet.fold1: empty collection"-fold1 f (T a x b) = fold f (fold f x a) b--fold1' _ E = error "UnbalancedSet.fold1': empty collection"-fold1' f (T a x b) = fold' f (fold' f x a) b--deleteMin E = E-deleteMin (T E _ b) = b-deleteMin (T a x b) = T (deleteMin a) x b--deleteMax E = E-deleteMax (T a _ E) = a-deleteMax (T a x b) = T a x (deleteMax b)--unsafeInsertMin x t = T E x t-unsafeInsertMax x t = T t x E--unsafeFromOrdSeq xs = fst (ins xs (S.size xs))-  where ins ys 0 = (E,ys)-        ins ys n = let m = n `div` 2-                       (a,ys') = ins ys m-                       Just (y,ys'') = S.lview ys'-                       (b,ys''') = ins ys'' (n - m - 1)-                   in (T a y b,ys''')--unsafeAppend a b = case minView b of-                     Nothing -> a-                     Just (x,b') -> T a x b'--filterLT _ E = E-filterLT y (T a x b) =-  case compare x y of-    LT -> T a x (filterLT y b)-    EQ -> a-    GT -> filterLT y a--filterLE _ E = E-filterLE y (T a x b) =-  case compare x y of-    LT -> T a x (filterLE y b)-    EQ -> T a x E-    GT -> filterLE y a--filterGT _ E = E-filterGT y (T a x b) =-  case compare x y of-    LT -> filterGT y b-    EQ -> b-    GT -> T (filterGT y a) x b--filterGE _ E = E-filterGE y (T a x b) =-  case compare x y of-    LT -> filterGE y b-    EQ -> T E x b-    GT -> T (filterGE y a) x b--partitionLT_GE _ E = (E,E)-partitionLT_GE y (T a x b) =-  case compare x y of-    LT -> (T a x b0,b1)-          where (b0,b1) = partitionLT_GE y b-    EQ -> (a,T E x b)-    GT -> (a0,T a1 x b)-          where (a0,a1) = partitionLT_GE y a--partitionLE_GT _ E = (E,E)-partitionLE_GT y (T a x b) =-  case compare x y of-    LT -> (T a x b0,b1)-          where (b0,b1) = partitionLE_GT y b-    EQ -> (T a x E,b)-    GT -> (a0,T a1 x b)-          where (a0,a1) = partitionLE_GT y a--partitionLT_GT _ E = (E,E)-partitionLT_GT y (T a x b) =-  case compare x y of-    LT -> (T a x b0,b1)-          where (b0,b1) = partitionLT_GT y b-    EQ -> (a,b)-    GT -> (a0,T a1 x b)-          where (a0,a1) = partitionLT_GT y a--minView E = fail "UnbalancedSet.minView: empty collection"-minView (T E x b) = return (x, b)-minView (T a x b) = return (y, T a' x b)-  where Just (y,a') = minView a--minElem E = error "UnbalancedSet.minElem: empty collection"-minElem (T E x _) = x-minElem (T a _ _) = minElem a--maxView E = fail "UnbalancedSet.maxView: empty collection"-maxView (T a x E) = return (x, a)-maxView (T a x b) = return (y, T a x b')-  where Just (y, b') = maxView b--maxElem E = error "UnbalancedSet.maxElem: empty collection"-maxElem (T _ x E) = x-maxElem (T _ _ b) = maxElem b--foldr _ e E = e-foldr f e (T a x b) = foldr f (f x (foldr f e b)) a--foldr' _ e E = e-foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a--foldl _ e E = e-foldl f e (T a x b) = foldl f (f (foldl f e a) x) b--foldl' _ e E = e-foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b--foldr1 _ E = error "UnbalancedSet.foldr1: empty collection"-foldr1 f (T a x E) = foldr f x a-foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a--foldr1' _ E = error "UnbalancedSet.foldr1': empty collection"-foldr1' f (T a x E) = foldr' f x a-foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a--foldl1 _ E = error "UnbalancedSet.foldl1: empty collection"-foldl1 f (T E x b) = foldl f x b-foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b--foldl1' _ E = error "UnbalancedSet.foldl1': empty collection"-foldl1' f (T E x b) = foldl' f x b-foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b--unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T a x b) =-    T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)--strict s@E = s-strict s@(T l _ r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s---- the remaining functions all use default definitions--fromSeq = fromSeqUsingUnionSeq-insert = insertUsingInsertWith-insertSeq = insertSeqUsingUnion-union = unionUsingUnionWith-unionSeq = unionSeqUsingReduce-deleteAll = delete-deleteSeq = deleteSeqUsingDelete-count = countUsingMember--toSeq = toSeqUsingFold-lookup = lookupUsingLookupM-lookupAll = lookupAllUsingLookupM-lookupWithDefault = lookupWithDefaultUsingLookupM-filter = filterUsingOrdLists-partition = partitionUsingOrdLists-toOrdSeq = toOrdSeqUsingFoldr--intersection = intersectionUsingIntersectionWith-difference = differenceUsingOrdLists-symmetricDifference = symmetricDifferenceUsingDifference-properSubset = properSubsetUsingOrdLists-subset = subsetUsingOrdLists-fromSeqWith = fromSeqWithUsingInsertWith-insertSeqWith = insertSeqWithUsingInsertWith-unionl = unionlUsingUnionWith-unionr = unionrUsingUnionWith-unionWith = unionWithUsingOrdLists-unionSeqWith = unionSeqWithUsingReducer-intersectionWith = intersectionWithUsingOrdLists---- instance declarations--instance Ord a => C.CollX (Set a) a where-  {singleton = singleton; fromSeq = fromSeq; insert = insert;-   insertSeq = insertSeq; unionSeq = unionSeq;-   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;-   null = null; size = size; member = member; count = count;-   strict = strict;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Set a) a where-  {deleteMin = deleteMin; deleteMax = deleteMax;-   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;-   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;-   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;-   filterGE = filterGE; partitionLT_GE = partitionLT_GE;-   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Set a) a where-  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;-   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Set a) a where-  {minView = minView; minElem = minElem; maxView = maxView;-   maxElem = maxElem; foldr = foldr; foldr' = foldr';-   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';-   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;-   unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => C.SetX (Set a) a where-  {intersection = intersection; difference = difference;-   symmetricDifference = symmetricDifference;-   properSubset = properSubset; subset = subset}--instance Ord a => C.Set (Set a) a where-  {fromSeqWith = fromSeqWith; insertWith = insertWith;-   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;-   unionWith = unionWith; unionSeqWith = unionSeqWith;-   intersectionWith = intersectionWith}--instance Ord a => C.OrdSetX (Set a) a--instance Ord a => C.OrdSet (Set a) a---instance Ord a => Eq (Set a) where-  xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Set a) where-   showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Set a) where-   readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Set a) where-  arbitrary = do (xs::[a]) <- arbitrary-                 return (Prelude.foldr insert empty xs)--instance (Ord a, CoArbitrary a) => CoArbitrary (Set a) where-  coarbitrary E = variant 0-  coarbitrary (T a x b) =-    variant 1 . coarbitrary a . coarbitrary x . coarbitrary b--instance (Ord a) => Semigroup (Set a) where-  (<>) = union--instance (Ord a) => Monoid (Set a) where-    mempty  = empty-    mappend = (SG.<>)-    mconcat = unionSeq--instance (Ord a) => Ord (Set a) where-    compare = compareUsingToOrdList+-- |
+--   Module      :  Data.Edison.Coll.UnbalancedSet
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Sets implemented as unbalanced binary search trees.
+
+module Data.Edison.Coll.UnbalancedSet (
+    -- * Set type
+    Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX
+
+    -- * CollX operations
+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
+    deleteSeq,null,size,member,count,strict,structuralInvariant,
+
+    -- * Coll operations
+    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',
+    fold1,fold1',filter,partition,strictWith,
+
+    -- * OrdCollX operations
+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,
+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,
+    partitionLE_GT,partitionLT_GT,
+
+    -- * OrdColl operations
+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',
+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,
+
+    -- * SetX operations
+    intersection,difference,symmetricDifference,properSubset,subset,
+
+    -- * Set operations
+    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,
+    unionSeqWith,intersectionWith,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter)
+import qualified Prelude
+import qualified Control.Monad.Fail as Fail
+import qualified Data.Edison.Coll as C
+import qualified Data.Edison.Seq as S
+import Data.Edison.Coll.Defaults
+import Data.Maybe (fromJust)
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName :: String
+empty      :: Set a
+singleton  :: a -> Set a
+fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a
+insert     :: Ord a => a -> Set a -> Set a
+insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a
+union      :: Ord a => Set a -> Set a -> Set a
+unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a
+delete     :: Ord a => a -> Set a -> Set a
+deleteAll  :: Ord a => a -> Set a -> Set a
+deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a
+null       :: Set a -> Bool
+size       :: Set a -> Int
+member     :: Ord a => a -> Set a -> Bool
+count      :: Ord a => a -> Set a -> Int
+strict     :: Set a -> Set a
+
+toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a
+lookup     :: Ord a => a -> Set a -> a
+lookupM    :: (Ord a, Fail.MonadFail m) => a -> Set a -> m a
+lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a
+lookupWithDefault :: Ord a => a -> a -> Set a -> a
+fold       :: (a -> b -> b) -> b -> Set a -> b
+fold1      :: (a -> a -> a) -> Set a -> a
+fold'      :: (a -> b -> b) -> b -> Set a -> b
+fold1'     :: (a -> a -> a) -> Set a -> a
+filter     :: Ord a => (a -> Bool) -> Set a -> Set a
+partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)
+strictWith :: (a -> b) -> Set a -> Set a
+
+deleteMin        :: Ord a => Set a -> Set a
+deleteMax        :: Ord a => Set a -> Set a
+unsafeInsertMin  :: Ord a => a -> Set a -> Set a
+unsafeInsertMax  :: Ord a => a -> Set a -> Set a
+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a
+unsafeAppend     :: Ord a => Set a -> Set a -> Set a
+filterLT         :: Ord a => a -> Set a -> Set a
+filterLE         :: Ord a => a -> Set a -> Set a
+filterGT         :: Ord a => a -> Set a -> Set a
+filterGE         :: Ord a => a -> Set a -> Set a
+partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)
+partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)
+partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)
+
+minView       :: (Fail.MonadFail m) => Set a -> m (a, Set a)
+minElem       :: Set a -> a
+maxView       :: (Fail.MonadFail m) => Set a -> m (a, Set a)
+maxElem       :: Set a -> a
+foldr         :: (a -> b -> b) -> b -> Set a -> b
+foldl         :: (b -> a -> b) -> b -> Set a -> b
+foldr1        :: (a -> a -> a) -> Set a -> a
+foldl1        :: (a -> a -> a) -> Set a -> a
+foldr'        :: (a -> b -> b) -> b -> Set a -> b
+foldl'        :: (b -> a -> b) -> b -> Set a -> b
+foldr1'       :: (a -> a -> a) -> Set a -> a
+foldl1'       :: (a -> a -> a) -> Set a -> a
+toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a
+
+intersection  :: Ord a => Set a -> Set a -> Set a
+difference    :: Ord a => Set a -> Set a -> Set a
+symmetricDifference :: Ord a => Set a -> Set a -> Set a
+properSubset  :: Ord a => Set a -> Set a -> Bool
+subset        :: Ord a => Set a -> Set a -> Bool
+
+fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a
+insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a
+insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a
+unionl       :: Ord a => Set a -> Set a -> Set a
+unionr       :: Ord a => Set a -> Set a -> Set a
+unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a
+unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a
+intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a
+unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a
+
+moduleName = "Data.Edison.Coll.UnbalancedSet"
+
+data Set a = E | T (Set a) a (Set a)
+
+-- invariants:
+--   * Binary Search Tree order
+structuralInvariant :: Ord a => Set a -> Bool
+structuralInvariant t = bounded Nothing Nothing t
+   where bounded _ _ E = True
+         bounded lo hi (T l x r)  = cmp_l lo x
+                                 && cmp_r x hi
+                                 && bounded lo (Just x) l
+                                 && bounded (Just x) hi r
+
+         cmp_l Nothing  _ = True
+         cmp_l (Just x) y = x < y
+
+         cmp_r _ Nothing  = True
+         cmp_r x (Just y) = x < y
+
+
+
+empty = E
+singleton x = T E x E
+
+insertWith c x = ins
+  where ins E = T E x E
+        ins (T a y b) =
+          case compare x y of
+            LT -> T (ins a) y b
+            EQ -> T a (c x y) b
+            GT -> T a y (ins b)
+
+delete _ E = E
+delete x (T a y b) =
+  case compare x y of
+    LT -> T (delete x a) y b
+    EQ -> unsafeAppend a b
+    GT -> T a y (delete x b)
+
+null E = True
+null (T _ _ _) = False
+
+size t = sz t 0
+  where sz E i = i
+        sz (T a _ b) i = sz a (sz b (i+1))
+
+member _ E = False
+member x (T a y b) =
+  case compare x y of
+    LT -> member x a
+    EQ -> True
+    GT -> member x b
+
+lookupM _ E = fail "UnbalancedSet.lookupM: XXX"
+lookupM x (T a y b) =
+  case compare x y of
+    LT -> lookupM x a
+    EQ -> return y
+    GT -> lookupM x b
+
+fold _ e E = e
+fold f e (T a x b) = f x (fold f (fold f e a) b)
+
+fold' _ e E = e
+fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b)
+
+fold1 _ E = error "UnbalancedSet.fold1: empty collection"
+fold1 f (T a x b) = fold f (fold f x a) b
+
+fold1' _ E = error "UnbalancedSet.fold1': empty collection"
+fold1' f (T a x b) = fold' f (fold' f x a) b
+
+deleteMin E = E
+deleteMin (T E _ b) = b
+deleteMin (T a x b) = T (deleteMin a) x b
+
+deleteMax E = E
+deleteMax (T a _ E) = a
+deleteMax (T a x b) = T a x (deleteMax b)
+
+unsafeInsertMin x t = T E x t
+unsafeInsertMax x t = T t x E
+
+unsafeFromOrdSeq xs = fst (ins xs (S.size xs))
+  where ins ys 0 = (E,ys)
+        ins ys n = let m = n `div` 2
+                       (a,ys') = ins ys m
+                       (y,ys'') = fromJust (S.lview ys')
+                       (b,ys''') = ins ys'' (n - m - 1)
+                   in (T a y b,ys''')
+
+unsafeAppend a b = case minView b of
+                     Nothing -> a
+                     Just (x,b') -> T a x b'
+
+filterLT _ E = E
+filterLT y (T a x b) =
+  case compare x y of
+    LT -> T a x (filterLT y b)
+    EQ -> a
+    GT -> filterLT y a
+
+filterLE _ E = E
+filterLE y (T a x b) =
+  case compare x y of
+    LT -> T a x (filterLE y b)
+    EQ -> T a x E
+    GT -> filterLE y a
+
+filterGT _ E = E
+filterGT y (T a x b) =
+  case compare x y of
+    LT -> filterGT y b
+    EQ -> b
+    GT -> T (filterGT y a) x b
+
+filterGE _ E = E
+filterGE y (T a x b) =
+  case compare x y of
+    LT -> filterGE y b
+    EQ -> T E x b
+    GT -> T (filterGE y a) x b
+
+partitionLT_GE _ E = (E,E)
+partitionLT_GE y (T a x b) =
+  case compare x y of
+    LT -> (T a x b0,b1)
+          where (b0,b1) = partitionLT_GE y b
+    EQ -> (a,T E x b)
+    GT -> (a0,T a1 x b)
+          where (a0,a1) = partitionLT_GE y a
+
+partitionLE_GT _ E = (E,E)
+partitionLE_GT y (T a x b) =
+  case compare x y of
+    LT -> (T a x b0,b1)
+          where (b0,b1) = partitionLE_GT y b
+    EQ -> (T a x E,b)
+    GT -> (a0,T a1 x b)
+          where (a0,a1) = partitionLE_GT y a
+
+partitionLT_GT _ E = (E,E)
+partitionLT_GT y (T a x b) =
+  case compare x y of
+    LT -> (T a x b0,b1)
+          where (b0,b1) = partitionLT_GT y b
+    EQ -> (a,b)
+    GT -> (a0,T a1 x b)
+          where (a0,a1) = partitionLT_GT y a
+
+minView E = fail "UnbalancedSet.minView: empty collection"
+minView (T E x b) = return (x, b)
+minView (T a x b) = return (y, T a' x b)
+  where (y,a') = fromJust (minView a)
+
+minElem E = error "UnbalancedSet.minElem: empty collection"
+minElem (T E x _) = x
+minElem (T a _ _) = minElem a
+
+maxView E = fail "UnbalancedSet.maxView: empty collection"
+maxView (T a x E) = return (x, a)
+maxView (T a x b) = return (y, T a x b')
+  where (y, b') = fromJust (maxView b)
+
+maxElem E = error "UnbalancedSet.maxElem: empty collection"
+maxElem (T _ x E) = x
+maxElem (T _ _ b) = maxElem b
+
+foldr _ e E = e
+foldr f e (T a x b) = foldr f (f x (foldr f e b)) a
+
+foldr' _ e E = e
+foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a
+
+foldl _ e E = e
+foldl f e (T a x b) = foldl f (f (foldl f e a) x) b
+
+foldl' _ e E = e
+foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b
+
+foldr1 _ E = error "UnbalancedSet.foldr1: empty collection"
+foldr1 f (T a x E) = foldr f x a
+foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a
+
+foldr1' _ E = error "UnbalancedSet.foldr1': empty collection"
+foldr1' f (T a x E) = foldr' f x a
+foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a
+
+foldl1 _ E = error "UnbalancedSet.foldl1: empty collection"
+foldl1 f (T E x b) = foldl f x b
+foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b
+
+foldl1' _ E = error "UnbalancedSet.foldl1': empty collection"
+foldl1' f (T E x b) = foldl' f x b
+foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b
+
+unsafeMapMonotonic _ E = E
+unsafeMapMonotonic f (T a x b) =
+    T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)
+
+strict s@E = s
+strict s@(T l _ r) = strict l `seq` strict r `seq` s
+
+strictWith _ s@E = s
+strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s
+
+-- the remaining functions all use default definitions
+
+fromSeq = fromSeqUsingUnionSeq
+insert = insertUsingInsertWith
+insertSeq = insertSeqUsingUnion
+union = unionUsingUnionWith
+unionSeq = unionSeqUsingReduce
+deleteAll = delete
+deleteSeq = deleteSeqUsingDelete
+count = countUsingMember
+
+toSeq = toSeqUsingFold
+lookup = lookupUsingLookupM
+lookupAll = lookupAllUsingLookupM
+lookupWithDefault = lookupWithDefaultUsingLookupM
+filter = filterUsingOrdLists
+partition = partitionUsingOrdLists
+toOrdSeq = toOrdSeqUsingFoldr
+
+intersection = intersectionUsingIntersectionWith
+difference = differenceUsingOrdLists
+symmetricDifference = symmetricDifferenceUsingDifference
+properSubset = properSubsetUsingOrdLists
+subset = subsetUsingOrdLists
+fromSeqWith = fromSeqWithUsingInsertWith
+insertSeqWith = insertSeqWithUsingInsertWith
+unionl = unionlUsingUnionWith
+unionr = unionrUsingUnionWith
+unionWith = unionWithUsingOrdLists
+unionSeqWith = unionSeqWithUsingReducer
+intersectionWith = intersectionWithUsingOrdLists
+
+-- instance declarations
+
+instance Ord a => C.CollX (Set a) a where
+  {singleton = singleton; fromSeq = fromSeq; insert = insert;
+   insertSeq = insertSeq; unionSeq = unionSeq;
+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
+   null = null; size = size; member = member; count = count;
+   strict = strict;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Ord a => C.OrdCollX (Set a) a where
+  {deleteMin = deleteMin; deleteMax = deleteMax;
+   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;
+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;
+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}
+
+instance Ord a => C.Coll (Set a) a where
+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM;
+   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   filter = filter; partition = partition; strictWith = strictWith}
+
+instance Ord a => C.OrdColl (Set a) a where
+  {minView = minView; minElem = minElem; maxView = maxView;
+   maxElem = maxElem; foldr = foldr; foldr' = foldr';
+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';
+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;
+   unsafeMapMonotonic = unsafeMapMonotonic}
+
+instance Ord a => C.SetX (Set a) a where
+  {intersection = intersection; difference = difference;
+   symmetricDifference = symmetricDifference;
+   properSubset = properSubset; subset = subset}
+
+instance Ord a => C.Set (Set a) a where
+  {fromSeqWith = fromSeqWith; insertWith = insertWith;
+   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;
+   unionWith = unionWith; unionSeqWith = unionSeqWith;
+   intersectionWith = intersectionWith}
+
+instance Ord a => C.OrdSetX (Set a) a
+
+instance Ord a => C.OrdSet (Set a) a
+
+
+instance Ord a => Eq (Set a) where
+  xs == ys = C.toOrdList xs == C.toOrdList ys
+
+instance (Ord a, Show a) => Show (Set a) where
+   showsPrec = showsPrecUsingToList
+
+instance (Ord a, Read a) => Read (Set a) where
+   readsPrec = readsPrecUsingFromList
+
+
+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
+  arbitrary = do (xs::[a]) <- arbitrary
+                 return (Prelude.foldr insert empty xs)
+
+instance (Ord a, CoArbitrary a) => CoArbitrary (Set a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (T a x b) =
+    variant (1 :: Int) . coarbitrary a . coarbitrary x . coarbitrary b
+
+instance (Ord a) => Semigroup (Set a) where
+  (<>) = union
+
+instance (Ord a) => Monoid (Set a) where
+    mempty  = empty
+    mappend = (SG.<>)
+    mconcat = unionSeq
+
+instance (Ord a) => Ord (Set a) where
+    compare = compareUsingToOrdList

src/Data/Edison/Concrete/FingerTree.hs view

@@ -1,788 +1,788 @@-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Edison.Concrete.FingerTree--- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006--- License     :  BSD-style--- Maintainer  :  robdockins AT fastmail DOT fm--- Stability   :  internal (non-stable)--- Portability :  non-portable (MPTCs and functional dependencies)------ A general sequence representation with arbitrary annotations, for--- use as a base for implementations of various collection types, as--- described in section 4 of------    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <https://www.cs.tufts.edu/~nr/cs257/archive/ralf-hinze/finger-trees.pdf>------ This data structure forms the basis of the "Data.Edison.Seq.FingerSeq"--- sequence data structure.------ An amortized running time is given for each operation, with /n/--- referring to the length of the sequence.  These bounds hold even in--- a persistent (shared) setting.-----------------------------------------------------------------------------------{--------------------------------------------------------------------Copyright 2004, 2008, The University Court of the University of Glasgow.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.--- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.-------------------------------------------------------------------------------}---module Data.Edison.Concrete.FingerTree (-        FingerTree,-        Split(..),--        empty, singleton, lcons, rcons, append,-        fromList, toList, null, size, lview, rview,-        split, takeUntil, dropUntil, splitTree,-        reverse, mapTree, foldFT, reduce1, reduce1',-        strict, strictWith, structuralInvariant--        -- traverse'-        ) where--import Prelude hiding (null, reverse)-import Data.Monoid-import Test.QuickCheck--import Data.Edison.Prelude--import Control.Monad (liftM2, liftM3, liftM4)-import qualified Control.Monad.Fail as Fail---infixr 5 `lcons`-infixl 5 `rcons0`--data Digit a-        = One a-        | Two a a-        | Three a a a-        | Four a a a a-        deriving Show--foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b-foldDigit _ f (One a) = f a-foldDigit mapp f (Two a b) = f a `mapp` f b-foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c-foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d--reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b-reduceDigit _ f (One a) = f a-reduceDigit mapp f (Two a b) = f a `mapp` f b-reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c-reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d)--digitToList :: Digit a -> [a] -> [a]-digitToList (One a)        xs = a : xs-digitToList (Two a b)      xs = a : b : xs-digitToList (Three a b c)  xs = a : b : c : xs-digitToList (Four a b c d) xs = a : b : c : d : xs--sizeDigit :: (a -> Int) -> Digit a -> Int-sizeDigit f (One x)        = f x-sizeDigit f (Two x y)      = f x + f y-sizeDigit f (Three x y z)  = f x + f y + f z-sizeDigit f (Four x y z w) = f x + f y + f z + f w--instance (Measured v a) => Measured v (Digit a) where-        measure = foldDigit mappend measure--data Node v a = Node2 !v a a | Node3 !v a a a-        deriving Show--sizeNode :: (a -> Int) -> Node v a -> Int-sizeNode f (Node2 _ x y)   = f x + f y-sizeNode f (Node3 _ x y z) = f x + f y + f z--foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b-foldNode mapp f (Node2 _ a b)   = f a `mapp` f b-foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c--nodeToList :: Node v a -> [a] -> [a]-nodeToList (Node2 _ a b)   xs = a : b : xs-nodeToList (Node3 _ a b c) xs = a : b : c : xs--node2        ::  (Measured v a) => a -> a -> Node v a-node2 a b    =   Node2 (measure a `mappend` measure b) a b--node3        ::  (Measured v a) => a -> a -> a -> Node v a-node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c--instance (Monoid v) => Measured v (Node v a) where-        measure (Node2 v _ _)    =  v-        measure (Node3 v _ _ _)  =  v--nodeToDigit :: Node v a -> Digit a-nodeToDigit (Node2 _ a b) = Two a b-nodeToDigit (Node3 _ a b c) = Three a b c----- | Finger trees with element type @a@, annotated with measures of type @v@.--- The operations enforce the constraint @'Measured' v a@.-data FingerTree v a-        = Empty-        | Single a-        | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)--deep ::  (Measured v a) =>-         Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a-deep pr m sf  =   Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf--structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool-structuralInvariant Empty      = True-structuralInvariant (Single _) = True-structuralInvariant (Deep v pr m sf) =-     v == foldDigit mappend measure pr `mappend`-          foldFT    mempty mappend (foldNode mappend measure) m `mappend`-          foldDigit mappend measure sf--instance (Measured v a) => Measured v (FingerTree v a) where-        measure Empty           =  mempty-        measure (Single x)      =  measure x-        measure (Deep v _ _ _)  =  v--sizeFT :: (a -> Int) -> FingerTree v a -> Int-sizeFT _ Empty            = 0-sizeFT f (Single x)       = f x-sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2--size :: FingerTree v a -> Int-size = sizeFT (const 1)--foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b-foldFT mz _ _ Empty      = mz-foldFT _ _ f (Single x) = f x-foldFT mz mapp f (Deep _ pr m sf) =-             foldDigit  mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf--ftToList :: FingerTree v a -> [a] -> [a]-ftToList Empty xs             = xs-ftToList (Single a) xs        = a : xs-ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs)--toList :: FingerTree v a -> [a]-toList ft = ftToList ft []--reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b-reduce1_aux mapp f pr Empty sf =-     (reduceDigit mapp f pr) `mapp`-     (reduceDigit mapp f sf)--reduce1_aux mapp f pr (Single x) sf =-     (reduceDigit mapp f pr) `mapp`-     (foldNode mapp f x)     `mapp`-     (reduceDigit mapp f sf)--reduce1_aux mapp f pr (Deep _ pr' m sf') sf =-     (reduceDigit mapp f pr) `mapp`-     (reduce1_aux mapp-        (foldNode mapp f)-            pr' m sf')       `mapp`-     (reduceDigit mapp f sf)--reduce1 :: (a -> a -> a) -> FingerTree v a -> a-reduce1 _ Empty             = error "FingerTree.reduce1: empty tree"-reduce1 _ (Single x)        = x-reduce1 mapp (Deep _ pr m sf)  = reduce1_aux mapp id pr m sf--reduce1' :: (a -> a -> a) -> FingerTree v a -> a-reduce1' _ Empty            = error "FingerTree.reduce1': empty tree"-reduce1' _ (Single x)       = x-reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf-  where mapp' x y = x `seq` y `seq` mapp x y---strict :: FingerTree v a -> FingerTree v a-strict xs = foldFT () seq (const ()) xs `seq` xs--strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a-strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs--instance (Measured v a, Eq a) => Eq (FingerTree v a) where-        xs == ys = toList xs == toList ys--instance (Measured v a, Ord a) => Ord (FingerTree v a) where-        compare xs ys = compare (toList xs) (toList ys)--instance (Measured v a, Show a) => Show (FingerTree v a) where-        showsPrec p xs = showParen (p > 10) $-                showString "fromList " . shows (toList xs)--mapTree :: (Measured v2 a2) =>-        (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2-mapTree _ Empty = Empty-mapTree f (Single x) = Single (f x)-mapTree f (Deep _ pr m sf) =-        deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)--mapNode :: (Measured v2 a2) =>-        (a1 -> a2) -> Node v1 a1 -> Node v2 a2-mapNode f (Node2 _ a b) = node2 (f a) (f b)-mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)--mapDigit :: (a -> b) -> Digit a -> Digit b-mapDigit f (One a) = One (f a)-mapDigit f (Two a b) = Two (f a) (f b)-mapDigit f (Three a b c) = Three (f a) (f b) (f c)-mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)---{---- | Like 'traverse', but with a more constrained type.-traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>-        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)-traverse' = traverseTree--traverseTree :: (Measured v2 a2, Applicative f) =>-        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)-traverseTree _ Empty = pure Empty-traverseTree f (Single x) = Single <$> f x-traverseTree f (Deep _ pr m sf) =-        deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf--traverseNode :: (Measured v2 a2, Applicative f) =>-        (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)-traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b-traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c--traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)-traverseDigit f (One a) = One <$> f a-traverseDigit f (Two a b) = Two <$> f a <*> f b-traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c-traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d--}---- | /O(1)/. The empty sequence.-empty :: Measured v a => FingerTree v a-empty = Empty---- | /O(1)/. A singleton sequence.-singleton :: Measured v a => a -> FingerTree v a-singleton = Single---- | /O(n)/. Create a sequence from a finite list of elements.-fromList :: (Measured v a) => [a] -> FingerTree v a-fromList = foldr lcons Empty---- | /O(1)/. Add an element to the left end of a sequence.-lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a-a `lcons` Empty         =  Single a-a `lcons` Single b              =  deep (One a) Empty (One b)-a `lcons` Deep _ (Four b c d e) m sf = m `seq`-        deep (Two a b) (node3 c d e `lcons` m) sf-a `lcons` Deep _ pr m sf        =  deep (consDigit a pr) m sf--consDigit :: a -> Digit a -> Digit a-consDigit a (One b) = Two a b-consDigit a (Two b c) = Three a b c-consDigit a (Three b c d) = Four a b c d-consDigit _ _ = error "FingerTree.consDigit: bug!"---- | /O(1)/. Add an element to the right end of a sequence.-rcons ::  (Measured v a) => a -> FingerTree v a -> FingerTree v a-rcons = flip rcons0--rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a-Empty `rcons0` a                =  Single a-Single a `rcons0` b             =  deep (One a) Empty (One b)-Deep _ pr m (Four a b c d) `rcons0` e = m `seq`-        deep pr (m `rcons0` node3 a b c) (Two d e)-Deep _ pr m sf `rcons0` x       =  deep pr m (snocDigit sf x)--snocDigit :: Digit a -> a -> Digit a-snocDigit (One a) b = Two a b-snocDigit (Two a b) c = Three a b c-snocDigit (Three a b c) d = Four a b c d-snocDigit _ _ = error "FingerTree.snocDigit: bug!"---- | /O(1)/. Is this the empty sequence?-null :: (Measured v a) => FingerTree v a -> Bool-null Empty = True-null _ = False---- | /O(1)/. Analyse the left end of a sequence.-lview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a,FingerTree v a)-lview Empty                 =  fail "FingerTree.lview: empty tree"-lview (Single x)            =  return (x, Empty)-lview (Deep _ (One x) m sf) =  return . (,) x $-        case lview m of-          Nothing     -> digitToTree sf-          Just (a,m') -> deep (nodeToDigit a) m' sf--lview (Deep _ pr m sf)      =  return (lheadDigit pr, deep (ltailDigit pr) m sf)--lheadDigit :: Digit a -> a-lheadDigit (One a) = a-lheadDigit (Two a _) = a-lheadDigit (Three a _ _) = a-lheadDigit (Four a _ _ _) = a--ltailDigit :: Digit a -> Digit a-ltailDigit (Two _ b) = One b-ltailDigit (Three _ b c) = Two b c-ltailDigit (Four _ b c d) = Three b c d-ltailDigit _ = error "FingerTree.ltailDigit: bug!"---- | /O(1)/. Analyse the right end of a sequence.-rview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a, FingerTree v a)-rview Empty                  = fail "FingerTree.rview: empty tree"-rview (Single x)             = return (x, Empty)-rview (Deep _ pr m (One x))  = return . (,) x $-        case rview m of-           Nothing      -> digitToTree pr-           Just (a,m')  -> deep pr m' (nodeToDigit a)--rview (Deep _ pr m sf)       =  return (rheadDigit sf, deep pr m (rtailDigit sf))---rheadDigit :: Digit a -> a-rheadDigit (One a) = a-rheadDigit (Two _ b) = b-rheadDigit (Three _ _ c) = c-rheadDigit (Four _ _ _ d) = d--rtailDigit :: Digit a -> Digit a-rtailDigit (Two a _) = One a-rtailDigit (Three a b _) = Two a b-rtailDigit (Four a b c _) = Three a b c-rtailDigit _ = error "FingerTree.rtailDigit: bug!"--digitToTree :: (Measured v a) => Digit a -> FingerTree v a-digitToTree (One a) = Single a-digitToTree (Two a b) = deep (One a) Empty (One b)-digitToTree (Three a b c) = deep (Two a b) Empty (One c)-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)----- | /O(log(min(n1,n2)))/. Concatenate two sequences.-append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a-append =  appendTree0--appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a-appendTree0 Empty xs =-        xs-appendTree0 xs Empty =-        xs-appendTree0 (Single x) xs =-        x `lcons` xs-appendTree0 xs (Single x) =-        xs `rcons0` x-appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =-        deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2--addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits0 m1 (One a) (One b) m2 =-        appendTree1 m1 (node2 a b) m2-addDigits0 m1 (One a) (Two b c) m2 =-        appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (One a) (Three b c d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (One a) (Four b c d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (One c) m2 =-        appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (Two a b) (Two c d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Two a b) (Three c d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (Four c d e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (One d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Three a b c) (Two d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Three a b c) (Three d e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (Four d e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (One e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Four a b c d) (Two e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Four a b c d) (Three e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2--appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a-appendTree1 Empty a xs =-        a `lcons` xs-appendTree1 xs a Empty =-        xs `rcons0` a-appendTree1 (Single x) a xs =-        x `lcons` (a `lcons` xs)-appendTree1 xs a (Single x) =-        xs `rcons0` a `rcons0` x-appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =-        deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2--addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits1 m1 (One a) b (One c) m2 =-        appendTree1 m1 (node3 a b c) m2-addDigits1 m1 (One a) b (Two c d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (One a) b (Three c d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (One a) b (Four c d e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (One d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (Two a b) c (Two d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Two a b) c (Three d e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (Four d e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (One e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Three a b c) d (Two e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Three a b c) d (Three e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (One f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Four a b c d) e (Two f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2--appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree2 Empty a b xs =-        a `lcons` (b `lcons` xs)-appendTree2 xs a b Empty =-        xs `rcons0` a `rcons0` b-appendTree2 (Single x) a b xs =-        x `lcons` (a `lcons` (b `lcons` xs))-appendTree2 xs a b (Single x) =-        xs `rcons0` a `rcons0` b `rcons0` x-appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =-        deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2--addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits2 m1 (One a) b c (One d) m2 =-        appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits2 m1 (One a) b c (Two d e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (One a) b c (Three d e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (One a) b c (Four d e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (One e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (Two a b) c d (Two e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Two a b) c d (Three e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (One f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Three a b c) d e (Two f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (One g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2--appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree3 Empty a b c xs =-        a `lcons` (b `lcons` (c `lcons` xs))-appendTree3 xs a b c Empty =-        xs `rcons0` a `rcons0` b `rcons0` c-appendTree3 (Single x) a b c xs =-        x `lcons` (a `lcons` (b `lcons` (c `lcons` xs)))-appendTree3 xs a b c (Single x) =-        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x-appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =-        deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2--addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits3 m1 (One a) b c d (One e) m2 =-        appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits3 m1 (One a) b c d (Two e f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (One a) b c d (Three e f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (One a) b c d (Four e f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (One f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (Two a b) c d e (Two f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (One g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (One h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2--appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree4 Empty a b c d xs =-        a `lcons` b `lcons` c `lcons` d `lcons` xs-appendTree4 xs a b c d Empty =-        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d-appendTree4 (Single x) a b c d xs =-        x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs-appendTree4 xs a b c d (Single x) =-        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x-appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =-        deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2--addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits4 m1 (One a) b c d e (One f) m2 =-        appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits4 m1 (One a) b c d e (Two f g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (One a) b c d e (Three f g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (One g) m2 =-        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (One h) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =-        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =-        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2----- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate--- on the accumulated measure changes from 'False' to 'True'.-split ::  (Measured v a) =>-          (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)-split _p Empty  =  (Empty, Empty)-split p xs-  | p (measure xs) =  (l, x `lcons` r)-  | otherwise   =  (xs, Empty)-  where Split l x r = splitTree p mempty xs--takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a-takeUntil p  =  fst . split p--dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a-dropUntil p  =  snd . split p--data Split t a = Split t a t--splitTree ::    (Measured v a) =>-                (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a-splitTree _ _ Empty = error "FingerTree.splitTree: bug!"-splitTree _p _i (Single x) = Split Empty x Empty-splitTree p i (Deep _ pr m sf)-  | p vpr       =  let  Split l x r     =  splitDigit p i pr-                   in   Split (maybe Empty digitToTree l) x (deepL r m sf)-  | p vm        =  let  Split ml xs mr  =  splitTree p vpr m-                        Split l x r     =  splitNode p (vpr `mappendVal` ml) xs-                   in   Split (deepR pr  ml l) x (deepL r mr sf)-  | otherwise   =  let  Split l x r     =  splitDigit p vm sf-                   in   Split (deepR pr  m  l) x (maybe Empty digitToTree r)-  where vpr     =  i    `mappend`  measure pr-        vm      =  vpr  `mappendVal` m--mappendVal :: (Measured v a) => v -> FingerTree v a -> v-mappendVal v Empty = v-mappendVal v t = v `mappend` measure t--deepL          ::  (Measured v a) =>-        Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a-deepL Nothing m sf      =   case lview m of-        Nothing     ->  digitToTree sf-        Just (a,m') ->  deep (nodeToDigit a) m' sf-deepL (Just pr) m sf    =   deep pr m sf--deepR          ::  (Measured v a) =>-        Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a-deepR pr m Nothing      =   case rview m of-        Nothing     ->  digitToTree pr-        Just (a,m') ->  deep pr m' (nodeToDigit a)-deepR pr m (Just sf)    =   deep pr m sf--splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->-                Split (Maybe (Digit a)) a-splitNode p i (Node2 _ a b)-  | p va        = Split Nothing a (Just (One b))-  | otherwise   = Split (Just (One a)) b Nothing-  where va      = i `mappend` measure a-splitNode p i (Node3 _ a b c)-  | p va        = Split Nothing a (Just (Two b c))-  | p vab       = Split (Just (One a)) b (Just (One c))-  | otherwise   = Split (Just (Two a b)) c Nothing-  where va      = i `mappend` measure a-        vab     = va `mappend` measure b--splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->-                Split (Maybe (Digit a)) a-splitDigit _ i (One a) = i `seq` Split Nothing a Nothing-splitDigit p i (Two a b)-  | p va        = Split Nothing a (Just (One b))-  | otherwise   = Split (Just (One a)) b Nothing-  where va      = i `mappend` measure a-splitDigit p i (Three a b c)-  | p va        = Split Nothing a (Just (Two b c))-  | p vab       = Split (Just (One a)) b (Just (One c))-  | otherwise   = Split (Just (Two a b)) c Nothing-  where va      = i `mappend` measure a-        vab     = va `mappend` measure b-splitDigit p i (Four a b c d)-  | p va        = Split Nothing a (Just (Three b c d))-  | p vab       = Split (Just (One a)) b (Just (Two c d))-  | p vabc      = Split (Just (Two a b)) c (Just (One d))-  | otherwise   = Split (Just (Three a b c)) d Nothing-  where va      = i `mappend` measure a-        vab     = va `mappend` measure b-        vabc    = vab `mappend` measure c----- | /O(n)/. The reverse of a sequence.-reverse :: (Measured v a) => FingerTree v a -> FingerTree v a-reverse = reverseTree id--reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2-reverseTree _ Empty = Empty-reverseTree f (Single x) = Single (f x)-reverseTree f (Deep _ pr m sf) =-        deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)--reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2-reverseNode f (Node2 _ a b) = node2 (f b) (f a)-reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)--reverseDigit :: (a -> b) -> Digit a -> Digit b-reverseDigit f (One a) = One (f a)-reverseDigit f (Two a b) = Two (f b) (f a)-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)--two :: Monad m => m a -> m (a, a)-two m = liftM2 (,) m m--three :: Monad m => m a -> m (a, a, a)-three m = liftM3 (,,) m m m--four :: Monad m => m a -> m (a, a, a, a)-four m = liftM4 (,,,) m m m m--instance (Arbitrary a) => Arbitrary (Digit a) where-  arbitrary = oneof-              [ arbitrary       >>= \x         -> return (One x)-              , two arbitrary   >>= \(x,y)     -> return (Two x y)-              , three arbitrary >>= \(x,y,z)   -> return (Three x y z)-              , four arbitrary  >>= \(x,y,z,w) -> return (Four x y z w)-              ]---instance (CoArbitrary a) => CoArbitrary (Digit a) where-  coarbitrary p = case p of-      One x        -> variant 0 . coarbitrary x-      Two x y      -> variant 1 . coarbitrary x . coarbitrary y-      Three x y z  -> variant 2 . coarbitrary x . coarbitrary y-                      . coarbitrary z-      Four x y z w -> variant 3 . coarbitrary x . coarbitrary y-                      . coarbitrary z . coarbitrary w---instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where-  arbitrary = oneof-              [ two arbitrary   >>= \(x,y)     -> return (node2 x y)-              , three arbitrary >>= \(x,y,z)   -> return (node3 x y z)-              ]--instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where-  coarbitrary p = case p of-       Node2 _ x y   -> variant 0 . coarbitrary x . coarbitrary y-       Node3 _ x y z -> variant 1 . coarbitrary x . coarbitrary y . coarbitrary z---instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where-  arbitrary = oneof-               [ return Empty-               , arbitrary >>= return . Single-               , do-                   pf <- arbitrary-                   m  <- arbitrary-                   sf <- arbitrary-                   return (deep pf m sf)-               ]--instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where-  coarbitrary p = case p of-         Empty          -> variant 0-         Single x       -> variant 1 . coarbitrary x-         Deep _ sf m pf -> variant 2 . coarbitrary sf . coarbitrary m . coarbitrary pf+{-# LANGUAGE UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Edison.Concrete.FingerTree
+-- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006
+-- License     :  BSD-style
+-- Maintainer  :  robdockins AT fastmail DOT fm
+-- Stability   :  internal (non-stable)
+-- Portability :  non-portable (MPTCs and functional dependencies)
+--
+-- A general sequence representation with arbitrary annotations, for
+-- use as a base for implementations of various collection types, as
+-- described in section 4 of
+--
+--    * Ralf Hinze and Ross Paterson,
+--      \"Finger trees: a simple general-purpose data structure\",
+--      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
+--      <https://www.cs.tufts.edu/~nr/cs257/archive/ralf-hinze/finger-trees.pdf>
+--
+-- This data structure forms the basis of the "Data.Edison.Seq.FingerSeq"
+-- sequence data structure.
+--
+-- An amortized running time is given for each operation, with /n/
+-- referring to the length of the sequence.  These bounds hold even in
+-- a persistent (shared) setting.
+--
+-----------------------------------------------------------------------------
+
+{------------------------------------------------------------------
+
+Copyright 2004, 2008, The University Court of the University of Glasgow.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+
+-----------------------------------------------------------------------------}
+
+
+module Data.Edison.Concrete.FingerTree (
+        FingerTree,
+        Split(..),
+
+        empty, singleton, lcons, rcons, append,
+        fromList, toList, null, size, lview, rview,
+        split, takeUntil, dropUntil, splitTree,
+        reverse, mapTree, foldFT, reduce1, reduce1',
+        strict, strictWith, structuralInvariant
+
+        -- traverse'
+        ) where
+
+import Prelude hiding (null, reverse)
+import Data.Monoid
+import Test.QuickCheck
+
+import Data.Edison.Prelude
+
+import Control.Monad (liftM2, liftM3, liftM4)
+import qualified Control.Monad.Fail as Fail
+
+
+infixr 5 `lcons`
+infixl 5 `rcons0`
+
+data Digit a
+        = One a
+        | Two a a
+        | Three a a a
+        | Four a a a a
+        deriving Show
+
+foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
+foldDigit _ f (One a) = f a
+foldDigit mapp f (Two a b) = f a `mapp` f b
+foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c
+foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d
+
+reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
+reduceDigit _ f (One a) = f a
+reduceDigit mapp f (Two a b) = f a `mapp` f b
+reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c
+reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d)
+
+digitToList :: Digit a -> [a] -> [a]
+digitToList (One a)        xs = a : xs
+digitToList (Two a b)      xs = a : b : xs
+digitToList (Three a b c)  xs = a : b : c : xs
+digitToList (Four a b c d) xs = a : b : c : d : xs
+
+sizeDigit :: (a -> Int) -> Digit a -> Int
+sizeDigit f (One x)        = f x
+sizeDigit f (Two x y)      = f x + f y
+sizeDigit f (Three x y z)  = f x + f y + f z
+sizeDigit f (Four x y z w) = f x + f y + f z + f w
+
+instance (Measured v a) => Measured v (Digit a) where
+        measure = foldDigit mappend measure
+
+data Node v a = Node2 !v a a | Node3 !v a a a
+        deriving Show
+
+sizeNode :: (a -> Int) -> Node v a -> Int
+sizeNode f (Node2 _ x y)   = f x + f y
+sizeNode f (Node3 _ x y z) = f x + f y + f z
+
+foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b
+foldNode mapp f (Node2 _ a b)   = f a `mapp` f b
+foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c
+
+nodeToList :: Node v a -> [a] -> [a]
+nodeToList (Node2 _ a b)   xs = a : b : xs
+nodeToList (Node3 _ a b c) xs = a : b : c : xs
+
+node2        ::  (Measured v a) => a -> a -> Node v a
+node2 a b    =   Node2 (measure a `mappend` measure b) a b
+
+node3        ::  (Measured v a) => a -> a -> a -> Node v a
+node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c
+
+instance (Monoid v) => Measured v (Node v a) where
+        measure (Node2 v _ _)    =  v
+        measure (Node3 v _ _ _)  =  v
+
+nodeToDigit :: Node v a -> Digit a
+nodeToDigit (Node2 _ a b) = Two a b
+nodeToDigit (Node3 _ a b c) = Three a b c
+
+
+-- | Finger trees with element type @a@, annotated with measures of type @v@.
+-- The operations enforce the constraint @'Measured' v a@.
+data FingerTree v a
+        = Empty
+        | Single a
+        | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
+
+deep ::  (Measured v a) =>
+         Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
+deep pr m sf  =   Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf
+
+structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool
+structuralInvariant Empty      = True
+structuralInvariant (Single _) = True
+structuralInvariant (Deep v pr m sf) =
+     v == foldDigit mappend measure pr `mappend`
+          foldFT    mempty mappend (foldNode mappend measure) m `mappend`
+          foldDigit mappend measure sf
+
+instance (Measured v a) => Measured v (FingerTree v a) where
+        measure Empty           =  mempty
+        measure (Single x)      =  measure x
+        measure (Deep v _ _ _)  =  v
+
+sizeFT :: (a -> Int) -> FingerTree v a -> Int
+sizeFT _ Empty            = 0
+sizeFT f (Single x)       = f x
+sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2
+
+size :: FingerTree v a -> Int
+size = sizeFT (const 1)
+
+foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b
+foldFT mz _ _ Empty      = mz
+foldFT _ _ f (Single x) = f x
+foldFT mz mapp f (Deep _ pr m sf) =
+             foldDigit  mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf
+
+ftToList :: FingerTree v a -> [a] -> [a]
+ftToList Empty xs             = xs
+ftToList (Single a) xs        = a : xs
+ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs)
+
+toList :: FingerTree v a -> [a]
+toList ft = ftToList ft []
+
+reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b
+reduce1_aux mapp f pr Empty sf =
+     (reduceDigit mapp f pr) `mapp`
+     (reduceDigit mapp f sf)
+
+reduce1_aux mapp f pr (Single x) sf =
+     (reduceDigit mapp f pr) `mapp`
+     (foldNode mapp f x)     `mapp`
+     (reduceDigit mapp f sf)
+
+reduce1_aux mapp f pr (Deep _ pr' m sf') sf =
+     (reduceDigit mapp f pr) `mapp`
+     (reduce1_aux mapp
+        (foldNode mapp f)
+            pr' m sf')       `mapp`
+     (reduceDigit mapp f sf)
+
+reduce1 :: (a -> a -> a) -> FingerTree v a -> a
+reduce1 _ Empty             = error "FingerTree.reduce1: empty tree"
+reduce1 _ (Single x)        = x
+reduce1 mapp (Deep _ pr m sf)  = reduce1_aux mapp id pr m sf
+
+reduce1' :: (a -> a -> a) -> FingerTree v a -> a
+reduce1' _ Empty            = error "FingerTree.reduce1': empty tree"
+reduce1' _ (Single x)       = x
+reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf
+  where mapp' x y = x `seq` y `seq` mapp x y
+
+
+strict :: FingerTree v a -> FingerTree v a
+strict xs = foldFT () seq (const ()) xs `seq` xs
+
+strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a
+strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs
+
+instance (Measured v a, Eq a) => Eq (FingerTree v a) where
+        xs == ys = toList xs == toList ys
+
+instance (Measured v a, Ord a) => Ord (FingerTree v a) where
+        compare xs ys = compare (toList xs) (toList ys)
+
+instance (Measured v a, Show a) => Show (FingerTree v a) where
+        showsPrec p xs = showParen (p > 10) $
+                showString "fromList " . shows (toList xs)
+
+mapTree :: (Measured v2 a2) =>
+        (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
+mapTree _ Empty = Empty
+mapTree f (Single x) = Single (f x)
+mapTree f (Deep _ pr m sf) =
+        deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)
+
+mapNode :: (Measured v2 a2) =>
+        (a1 -> a2) -> Node v1 a1 -> Node v2 a2
+mapNode f (Node2 _ a b) = node2 (f a) (f b)
+mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)
+
+mapDigit :: (a -> b) -> Digit a -> Digit b
+mapDigit f (One a) = One (f a)
+mapDigit f (Two a b) = Two (f a) (f b)
+mapDigit f (Three a b c) = Three (f a) (f b) (f c)
+mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)
+
+
+{-
+-- | Like 'traverse', but with a more constrained type.
+traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
+        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
+traverse' = traverseTree
+
+traverseTree :: (Measured v2 a2, Applicative f) =>
+        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
+traverseTree _ Empty = pure Empty
+traverseTree f (Single x) = Single <$> f x
+traverseTree f (Deep _ pr m sf) =
+        deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf
+
+traverseNode :: (Measured v2 a2, Applicative f) =>
+        (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)
+traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b
+traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c
+
+traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)
+traverseDigit f (One a) = One <$> f a
+traverseDigit f (Two a b) = Two <$> f a <*> f b
+traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c
+traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
+-}
+
+-- | /O(1)/. The empty sequence.
+empty :: Measured v a => FingerTree v a
+empty = Empty
+
+-- | /O(1)/. A singleton sequence.
+singleton :: Measured v a => a -> FingerTree v a
+singleton = Single
+
+-- | /O(n)/. Create a sequence from a finite list of elements.
+fromList :: (Measured v a) => [a] -> FingerTree v a
+fromList = foldr lcons Empty
+
+-- | /O(1)/. Add an element to the left end of a sequence.
+lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
+a `lcons` Empty         =  Single a
+a `lcons` Single b              =  deep (One a) Empty (One b)
+a `lcons` Deep _ (Four b c d e) m sf = m `seq`
+        deep (Two a b) (node3 c d e `lcons` m) sf
+a `lcons` Deep _ pr m sf        =  deep (consDigit a pr) m sf
+
+consDigit :: a -> Digit a -> Digit a
+consDigit a (One b) = Two a b
+consDigit a (Two b c) = Three a b c
+consDigit a (Three b c d) = Four a b c d
+consDigit _ _ = error "FingerTree.consDigit: bug!"
+
+-- | /O(1)/. Add an element to the right end of a sequence.
+rcons ::  (Measured v a) => a -> FingerTree v a -> FingerTree v a
+rcons = flip rcons0
+
+rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
+Empty `rcons0` a                =  Single a
+Single a `rcons0` b             =  deep (One a) Empty (One b)
+Deep _ pr m (Four a b c d) `rcons0` e = m `seq`
+        deep pr (m `rcons0` node3 a b c) (Two d e)
+Deep _ pr m sf `rcons0` x       =  deep pr m (snocDigit sf x)
+
+snocDigit :: Digit a -> a -> Digit a
+snocDigit (One a) b = Two a b
+snocDigit (Two a b) c = Three a b c
+snocDigit (Three a b c) d = Four a b c d
+snocDigit _ _ = error "FingerTree.snocDigit: bug!"
+
+-- | /O(1)/. Is this the empty sequence?
+null :: (Measured v a) => FingerTree v a -> Bool
+null Empty = True
+null _ = False
+
+-- | /O(1)/. Analyse the left end of a sequence.
+lview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a,FingerTree v a)
+lview Empty                 =  fail "FingerTree.lview: empty tree"
+lview (Single x)            =  return (x, Empty)
+lview (Deep _ (One x) m sf) =  return . (,) x $
+        case lview m of
+          Nothing     -> digitToTree sf
+          Just (a,m') -> deep (nodeToDigit a) m' sf
+
+lview (Deep _ pr m sf)      =  return (lheadDigit pr, deep (ltailDigit pr) m sf)
+
+lheadDigit :: Digit a -> a
+lheadDigit (One a) = a
+lheadDigit (Two a _) = a
+lheadDigit (Three a _ _) = a
+lheadDigit (Four a _ _ _) = a
+
+ltailDigit :: Digit a -> Digit a
+ltailDigit (Two _ b) = One b
+ltailDigit (Three _ b c) = Two b c
+ltailDigit (Four _ b c d) = Three b c d
+ltailDigit _ = error "FingerTree.ltailDigit: bug!"
+
+-- | /O(1)/. Analyse the right end of a sequence.
+rview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a, FingerTree v a)
+rview Empty                  = fail "FingerTree.rview: empty tree"
+rview (Single x)             = return (x, Empty)
+rview (Deep _ pr m (One x))  = return . (,) x $
+        case rview m of
+           Nothing      -> digitToTree pr
+           Just (a,m')  -> deep pr m' (nodeToDigit a)
+
+rview (Deep _ pr m sf)       =  return (rheadDigit sf, deep pr m (rtailDigit sf))
+
+
+rheadDigit :: Digit a -> a
+rheadDigit (One a) = a
+rheadDigit (Two _ b) = b
+rheadDigit (Three _ _ c) = c
+rheadDigit (Four _ _ _ d) = d
+
+rtailDigit :: Digit a -> Digit a
+rtailDigit (Two a _) = One a
+rtailDigit (Three a b _) = Two a b
+rtailDigit (Four a b c _) = Three a b c
+rtailDigit _ = error "FingerTree.rtailDigit: bug!"
+
+digitToTree :: (Measured v a) => Digit a -> FingerTree v a
+digitToTree (One a) = Single a
+digitToTree (Two a b) = deep (One a) Empty (One b)
+digitToTree (Three a b c) = deep (Two a b) Empty (One c)
+digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
+
+
+-- | /O(log(min(n1,n2)))/. Concatenate two sequences.
+append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
+append =  appendTree0
+
+appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
+appendTree0 Empty xs =
+        xs
+appendTree0 xs Empty =
+        xs
+appendTree0 (Single x) xs =
+        x `lcons` xs
+appendTree0 xs (Single x) =
+        xs `rcons0` x
+appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
+        deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2
+
+addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits0 m1 (One a) (One b) m2 =
+        appendTree1 m1 (node2 a b) m2
+addDigits0 m1 (One a) (Two b c) m2 =
+        appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (One a) (Three b c d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (One a) (Four b c d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (One c) m2 =
+        appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (Two a b) (Two c d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Two a b) (Three c d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (Four c d e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (One d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Three a b c) (Two d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Three a b c) (Three d e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (Four d e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (One e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Four a b c d) (Two e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Four a b c d) (Three e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+
+appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
+appendTree1 Empty a xs =
+        a `lcons` xs
+appendTree1 xs a Empty =
+        xs `rcons0` a
+appendTree1 (Single x) a xs =
+        x `lcons` (a `lcons` xs)
+appendTree1 xs a (Single x) =
+        xs `rcons0` a `rcons0` x
+appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
+        deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
+
+addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits1 m1 (One a) b (One c) m2 =
+        appendTree1 m1 (node3 a b c) m2
+addDigits1 m1 (One a) b (Two c d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (One a) b (Three c d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (One a) b (Four c d e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (One d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (Two a b) c (Two d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Two a b) c (Three d e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (Four d e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (One e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Three a b c) d (Two e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Three a b c) d (Three e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (One f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Four a b c d) e (Two f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+
+appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree2 Empty a b xs =
+        a `lcons` (b `lcons` xs)
+appendTree2 xs a b Empty =
+        xs `rcons0` a `rcons0` b
+appendTree2 (Single x) a b xs =
+        x `lcons` (a `lcons` (b `lcons` xs))
+appendTree2 xs a b (Single x) =
+        xs `rcons0` a `rcons0` b `rcons0` x
+appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
+        deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
+
+addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits2 m1 (One a) b c (One d) m2 =
+        appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits2 m1 (One a) b c (Two d e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (One a) b c (Three d e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (One a) b c (Four d e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (One e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (Two a b) c d (Two e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Two a b) c d (Three e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (One f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Three a b c) d e (Two f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (One g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+
+appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree3 Empty a b c xs =
+        a `lcons` (b `lcons` (c `lcons` xs))
+appendTree3 xs a b c Empty =
+        xs `rcons0` a `rcons0` b `rcons0` c
+appendTree3 (Single x) a b c xs =
+        x `lcons` (a `lcons` (b `lcons` (c `lcons` xs)))
+appendTree3 xs a b c (Single x) =
+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x
+appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
+        deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
+
+addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits3 m1 (One a) b c d (One e) m2 =
+        appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits3 m1 (One a) b c d (Two e f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (One a) b c d (Three e f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (One a) b c d (Four e f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (One f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (Two a b) c d e (Two f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (One g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (One h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+
+appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree4 Empty a b c d xs =
+        a `lcons` b `lcons` c `lcons` d `lcons` xs
+appendTree4 xs a b c d Empty =
+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d
+appendTree4 (Single x) a b c d xs =
+        x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs
+appendTree4 xs a b c d (Single x) =
+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x
+appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
+        deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
+
+addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits4 m1 (One a) b c d e (One f) m2 =
+        appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits4 m1 (One a) b c d e (Two f g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (One a) b c d e (Three f g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (One g) m2 =
+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (One h) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
+
+
+-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate
+-- on the accumulated measure changes from 'False' to 'True'.
+split ::  (Measured v a) =>
+          (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
+split _p Empty  =  (Empty, Empty)
+split p xs
+  | p (measure xs) =  (l, x `lcons` r)
+  | otherwise   =  (xs, Empty)
+  where Split l x r = splitTree p mempty xs
+
+takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
+takeUntil p  =  fst . split p
+
+dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
+dropUntil p  =  snd . split p
+
+data Split t a = Split t a t
+
+splitTree ::    (Measured v a) =>
+                (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a
+splitTree _ _ Empty = error "FingerTree.splitTree: bug!"
+splitTree _p _i (Single x) = Split Empty x Empty
+splitTree p i (Deep _ pr m sf)
+  | p vpr       =  let  Split l x r     =  splitDigit p i pr
+                   in   Split (maybe Empty digitToTree l) x (deepL r m sf)
+  | p vm        =  let  Split ml xs mr  =  splitTree p vpr m
+                        Split l x r     =  splitNode p (vpr `mappendVal` ml) xs
+                   in   Split (deepR pr  ml l) x (deepL r mr sf)
+  | otherwise   =  let  Split l x r     =  splitDigit p vm sf
+                   in   Split (deepR pr  m  l) x (maybe Empty digitToTree r)
+  where vpr     =  i    `mappend`  measure pr
+        vm      =  vpr  `mappendVal` m
+
+mappendVal :: (Measured v a) => v -> FingerTree v a -> v
+mappendVal v Empty = v
+mappendVal v t = v `mappend` measure t
+
+deepL          ::  (Measured v a) =>
+        Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
+deepL Nothing m sf      =   case lview m of
+        Nothing     ->  digitToTree sf
+        Just (a,m') ->  deep (nodeToDigit a) m' sf
+deepL (Just pr) m sf    =   deep pr m sf
+
+deepR          ::  (Measured v a) =>
+        Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a
+deepR pr m Nothing      =   case rview m of
+        Nothing     ->  digitToTree pr
+        Just (a,m') ->  deep pr m' (nodeToDigit a)
+deepR pr m (Just sf)    =   deep pr m sf
+
+splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->
+                Split (Maybe (Digit a)) a
+splitNode p i (Node2 _ a b)
+  | p va        = Split Nothing a (Just (One b))
+  | otherwise   = Split (Just (One a)) b Nothing
+  where va      = i `mappend` measure a
+splitNode p i (Node3 _ a b c)
+  | p va        = Split Nothing a (Just (Two b c))
+  | p vab       = Split (Just (One a)) b (Just (One c))
+  | otherwise   = Split (Just (Two a b)) c Nothing
+  where va      = i `mappend` measure a
+        vab     = va `mappend` measure b
+
+splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->
+                Split (Maybe (Digit a)) a
+splitDigit _ i (One a) = i `seq` Split Nothing a Nothing
+splitDigit p i (Two a b)
+  | p va        = Split Nothing a (Just (One b))
+  | otherwise   = Split (Just (One a)) b Nothing
+  where va      = i `mappend` measure a
+splitDigit p i (Three a b c)
+  | p va        = Split Nothing a (Just (Two b c))
+  | p vab       = Split (Just (One a)) b (Just (One c))
+  | otherwise   = Split (Just (Two a b)) c Nothing
+  where va      = i `mappend` measure a
+        vab     = va `mappend` measure b
+splitDigit p i (Four a b c d)
+  | p va        = Split Nothing a (Just (Three b c d))
+  | p vab       = Split (Just (One a)) b (Just (Two c d))
+  | p vabc      = Split (Just (Two a b)) c (Just (One d))
+  | otherwise   = Split (Just (Three a b c)) d Nothing
+  where va      = i `mappend` measure a
+        vab     = va `mappend` measure b
+        vabc    = vab `mappend` measure c
+
+
+-- | /O(n)/. The reverse of a sequence.
+reverse :: (Measured v a) => FingerTree v a -> FingerTree v a
+reverse = reverseTree id
+
+reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
+reverseTree _ Empty = Empty
+reverseTree f (Single x) = Single (f x)
+reverseTree f (Deep _ pr m sf) =
+        deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)
+
+reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2
+reverseNode f (Node2 _ a b) = node2 (f b) (f a)
+reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)
+
+reverseDigit :: (a -> b) -> Digit a -> Digit b
+reverseDigit f (One a) = One (f a)
+reverseDigit f (Two a b) = Two (f b) (f a)
+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
+
+two :: Monad m => m a -> m (a, a)
+two m = liftM2 (,) m m
+
+three :: Monad m => m a -> m (a, a, a)
+three m = liftM3 (,,) m m m
+
+four :: Monad m => m a -> m (a, a, a, a)
+four m = liftM4 (,,,) m m m m
+
+instance (Arbitrary a) => Arbitrary (Digit a) where
+  arbitrary = oneof
+              [ arbitrary       >>= \x         -> return (One x)
+              , two arbitrary   >>= \(x,y)     -> return (Two x y)
+              , three arbitrary >>= \(x,y,z)   -> return (Three x y z)
+              , four arbitrary  >>= \(x,y,z,w) -> return (Four x y z w)
+              ]
+
+
+instance (CoArbitrary a) => CoArbitrary (Digit a) where
+  coarbitrary p = case p of
+      One x        -> variant (0 :: Int) . coarbitrary x
+      Two x y      -> variant (1 :: Int) . coarbitrary x . coarbitrary y
+      Three x y z  -> variant (2 :: Int) . coarbitrary x . coarbitrary y
+                      . coarbitrary z
+      Four x y z w -> variant (3 :: Int) . coarbitrary x . coarbitrary y
+                      . coarbitrary z . coarbitrary w
+
+
+instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where
+  arbitrary = oneof
+              [ two arbitrary   >>= \(x,y)     -> return (node2 x y)
+              , three arbitrary >>= \(x,y,z)   -> return (node3 x y z)
+              ]
+
+instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where
+  coarbitrary p = case p of
+       Node2 _ x y   -> variant (0 :: Int) . coarbitrary x . coarbitrary y
+       Node3 _ x y z -> variant (1 :: Int) . coarbitrary x . coarbitrary y . coarbitrary z
+
+
+instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where
+  arbitrary = oneof
+               [ return Empty
+               , arbitrary >>= return . Single
+               , do
+                   pf <- arbitrary
+                   m  <- arbitrary
+                   sf <- arbitrary
+                   return (deep pf m sf)
+               ]
+
+instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where
+  coarbitrary p = case p of
+         Empty          -> variant (0 :: Int)
+         Single x       -> variant (1 :: Int) . coarbitrary x
+         Deep _ sf m pf -> variant (2 :: Int) . coarbitrary sf . coarbitrary m . coarbitrary pf

src/Data/Edison/Seq/BankersQueue.hs view

@@ -1,440 +1,440 @@--- |---   Module      :  Data.Edison.Seq.BankersQueue---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   This module implements Banker's Queues. It has the standard running---   times from "Data.Edison.Seq" except for the following:------   * rcons, size, inBounds   @O( 1 )@------   /References:/------   * Chris Okasaki, /Purely Functional Data Structures/,---     1998, sections 6.3.2 and 8.4.1.------   * Chris Okasaki, \"Simple and efficient purely functional---     queues and deques\", /Journal of Function Programming/---     5(4):583-592, October 1995.--module Data.Edison.Seq.BankersQueue (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName--) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App--import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L-import Data.Monoid-import Data.Semigroup as SG-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a--structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BankersQueue"---data Seq a = Q !Int [a] [a] !Int---- invariant: front at least as long as rear-structuralInvariant (Q x f r y) =-    length f == x && length r == y && x >= y----- not exported-makeQ :: Int -> [a] -> [a] -> Int -> Seq a-makeQ i xs ys j-  | j > i     = Q (i + j) (xs ++ L.reverse ys) [] 0-  | otherwise = Q i xs ys j--empty = Q 0 [] [] 0-singleton x = Q 1 [x] [] 0-lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j-rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1)--append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =-    Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2--lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence"-lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j)--lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence"-lhead (Q _ (x:_) _ _) = x--lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence"-lheadM (Q _ (x:_) _ _) = return x--ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j-ltail _ = error "BankersQueue.ltail: empty sequence"--ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j)-ltailM _ = fail "BankersQueue.ltail: empty sequence"--rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1))-rview (Q i xs [] _) =-  case L.rview xs of-    Nothing      -> fail "BankersQueue.rview: empty sequence"-    Just (x,xs') -> return (x, Q (i-1) xs' [] 0)--rhead (Q _ _ (y:_) _) = y-rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence"-rhead (Q _ xs [] _) = L.rhead xs--rheadM (Q _ _ (y:_) _) = return y-rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence"-rheadM (Q _ xs [] _) = return (L.rhead xs)--rtail (Q i xs (_:ys) j) = Q i xs ys (j-1)-rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence"-rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0--rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1))-rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence"-rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0)--null (Q i _ _ _) = (i == 0)-size (Q i _ _ j) = i + j-reverse (Q i xs ys j) = makeQ j ys xs i--reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =-    Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2--fromList xs = Q (length xs) xs [] 0--toList (Q _ xs ys j)-  | j == 0 = xs-  | otherwise = xs ++ L.reverse ys--map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j---- local fn on lists-revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1-revfoldr _ e [] = e-revfoldr f e (x:xs) = revfoldr f (f x e) xs--revfoldr' :: (t -> a -> a) -> a -> [t] -> a-revfoldr' _ e [] = e-revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs---- local fn on lists-revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t-revfoldl _ e [] = e-revfoldl f e (x:xs) = f (revfoldl f e xs) x--revfoldl' :: (b -> t -> b) -> b -> [t] -> b-revfoldl' _ e [] = e-revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs)--fold  f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs-fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr  f e (Q _ xs ys _) = L.foldr  f (revfoldr  f e ys) xs-foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs-foldl  f e (Q _ xs ys _) = revfoldl  f (L.foldl  f e xs) ys-foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys--foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs-foldr1 f (Q i xs [] _)-  | i == 0 = error "BankersQueue.foldr1: empty sequence"-  | otherwise = L.foldr1 f xs--foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs-foldr1' f (Q i xs [] _)-  | i == 0 = error "BankersQueue.foldr1': empty sequence"-  | otherwise = L.foldr1' f xs--foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys-foldl1 _ _ = error "BankersQueue.foldl1: empty sequence"--foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys-foldl1' _ _ = error "BankersQueue.foldl1': empty sequence"--copy n x-  | n < 0     = empty-  | otherwise = Q n (L.copy n x) [] 0---- reduce1: given sizes could do more effective job of dividing evenly!--lookup idx q = runFail_ (lookupM idx q)--lookupM idx (Q i xs ys j)-  | idx < i   = L.lookupM idx xs-  | otherwise = L.lookupM (j - (idx - i) - 1) ys--lookupWithDefault d idx (Q i xs ys j)-  | idx < i   = L.lookupWithDefault d idx xs-  | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys--update idx e q@(Q i xs ys j)-  | idx < i = if idx < 0 then q-             else Q i (L.update idx e xs) ys j-  | otherwise = let k' = j - (idx - i) - 1-                in if k' < 0 then q-                   else Q i xs (L.update k' e ys) j--adjust f idx q@(Q i xs ys j)-  | idx < i = if idx < 0 then q-             else Q i (L.adjust f idx xs) ys j-  | otherwise = let k' = j - (idx - i) - 1-                in if k' < 0 then q-                   else Q i xs (L.adjust f k' ys) j--{--could do-  mapWithIndex   :: (Int -> a -> b) -> s a -> s b-  foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b-  foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b-but don't bother for now--}--take len q@(Q i xs ys j) =-  if len <= i then-    if len <= 0 then empty-    else Q len (L.take len xs) [] 0-  else let len' = len - i in-    if len' >= j then q-    else Q i xs (L.drop (j - len') ys) len'--drop len q@(Q i xs ys j) =-  if len <= i then-    if len <= 0 then q-    else makeQ (i - len) (L.drop len xs) ys j-  else let len' = len - i in-    if len' >= j then empty-    else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0-  -- could write more efficient version of reverse (take ...)--splitAt idx q@(Q i xs ys j) =-  if idx <= i then-    if idx <= 0 then (empty, q)-    else let (xs',xs'') = L.splitAt idx xs-         in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j)-  else let idx' = idx - i in-    if idx' >= j then (q, empty)-    else let (ys', ys'') = L.splitAt (j - idx') ys-         in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0)-      -- could do splitAt followed by reverse more efficiently...---strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l-strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l---- the remaining functions all use defaults--concat = concatUsingFoldr-concatMap = concatMapUsingFoldr-reducer = reducerUsingReduce1-reducel = reducelUsingReduce1-reduce1 = reduce1UsingLists-reducer' = reducer'UsingReduce1'-reducel' = reducel'UsingReduce1'-reduce1' = reduce1'UsingLists-inBounds = inBoundsUsingSize-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-subseq = subseqDefault-filter = filterUsingLists-partition = partitionUsingLists-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview-zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer';-   reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;-   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Eq a => Eq (Seq a) where-  q1 == q2 =-    (size q1 == size q2) && (toList q1 == toList q2)--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary =-    do xs <- arbitrary-       ys <- arbitrary-       return (let i = L.size xs-                   j = L.size ys-               in if i >= j then Q i xs ys j else Q j ys xs i)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary (Q _ xs ys _) = coarbitrary xs . coarbitrary ys--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.BankersQueue
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module implements Banker's Queues. It has the standard running
+--   times from "Data.Edison.Seq" except for the following:
+--
+--   * rcons, size, inBounds   @O( 1 )@
+--
+--   /References:/
+--
+--   * Chris Okasaki, /Purely Functional Data Structures/,
+--     1998, sections 6.3.2 and 8.4.1.
+--
+--   * Chris Okasaki, \"Simple and efficient purely functional
+--     queues and deques\", /Journal of Function Programming/
+--     5(4):583-592, October 1995.
+
+module Data.Edison.Seq.BankersQueue (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Monoid
+import Data.Semigroup as SG
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.BankersQueue"
+
+
+data Seq a = Q !Int [a] [a] !Int
+
+-- invariant: front at least as long as rear
+structuralInvariant (Q x f r y) =
+    length f == x && length r == y && x >= y
+
+
+-- not exported
+makeQ :: Int -> [a] -> [a] -> Int -> Seq a
+makeQ i xs ys j
+  | j > i     = Q (i + j) (xs ++ L.reverse ys) [] 0
+  | otherwise = Q i xs ys j
+
+empty = Q 0 [] [] 0
+singleton x = Q 1 [x] [] 0
+lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j
+rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1)
+
+append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =
+    Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2
+
+lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence"
+lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j)
+
+lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence"
+lhead (Q _ (x:_) _ _) = x
+
+lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence"
+lheadM (Q _ (x:_) _ _) = return x
+
+ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j
+ltail _ = error "BankersQueue.ltail: empty sequence"
+
+ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j)
+ltailM _ = fail "BankersQueue.ltail: empty sequence"
+
+rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1))
+rview (Q i xs [] _) =
+  case L.rview xs of
+    Nothing      -> fail "BankersQueue.rview: empty sequence"
+    Just (x,xs') -> return (x, Q (i-1) xs' [] 0)
+
+rhead (Q _ _ (y:_) _) = y
+rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence"
+rhead (Q _ xs [] _) = L.rhead xs
+
+rheadM (Q _ _ (y:_) _) = return y
+rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence"
+rheadM (Q _ xs [] _) = return (L.rhead xs)
+
+rtail (Q i xs (_:ys) j) = Q i xs ys (j-1)
+rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence"
+rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0
+
+rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1))
+rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence"
+rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0)
+
+null (Q i _ _ _) = (i == 0)
+size (Q i _ _ j) = i + j
+reverse (Q i xs ys j) = makeQ j ys xs i
+
+reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =
+    Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2
+
+fromList xs = Q (length xs) xs [] 0
+
+toList (Q _ xs ys j)
+  | j == 0 = xs
+  | otherwise = xs ++ L.reverse ys
+
+map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j
+
+-- local fn on lists
+revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1
+revfoldr _ e [] = e
+revfoldr f e (x:xs) = revfoldr f (f x e) xs
+
+revfoldr' :: (t -> a -> a) -> a -> [t] -> a
+revfoldr' _ e [] = e
+revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs
+
+-- local fn on lists
+revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t
+revfoldl _ e [] = e
+revfoldl f e (x:xs) = f (revfoldl f e xs) x
+
+revfoldl' :: (b -> t -> b) -> b -> [t] -> b
+revfoldl' _ e [] = e
+revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs)
+
+fold  f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs
+fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr  f e (Q _ xs ys _) = L.foldr  f (revfoldr  f e ys) xs
+foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs
+foldl  f e (Q _ xs ys _) = revfoldl  f (L.foldl  f e xs) ys
+foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys
+
+foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs
+foldr1 f (Q i xs [] _)
+  | i == 0 = error "BankersQueue.foldr1: empty sequence"
+  | otherwise = L.foldr1 f xs
+
+foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs
+foldr1' f (Q i xs [] _)
+  | i == 0 = error "BankersQueue.foldr1': empty sequence"
+  | otherwise = L.foldr1' f xs
+
+foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys
+foldl1 _ _ = error "BankersQueue.foldl1: empty sequence"
+
+foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys
+foldl1' _ _ = error "BankersQueue.foldl1': empty sequence"
+
+copy n x
+  | n < 0     = empty
+  | otherwise = Q n (L.copy n x) [] 0
+
+-- reduce1: given sizes could do more effective job of dividing evenly!
+
+lookup idx q = runFail_ (lookupM idx q)
+
+lookupM idx (Q i xs ys j)
+  | idx < i   = L.lookupM idx xs
+  | otherwise = L.lookupM (j - (idx - i) - 1) ys
+
+lookupWithDefault d idx (Q i xs ys j)
+  | idx < i   = L.lookupWithDefault d idx xs
+  | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys
+
+update idx e q@(Q i xs ys j)
+  | idx < i = if idx < 0 then q
+             else Q i (L.update idx e xs) ys j
+  | otherwise = let k' = j - (idx - i) - 1
+                in if k' < 0 then q
+                   else Q i xs (L.update k' e ys) j
+
+adjust f idx q@(Q i xs ys j)
+  | idx < i = if idx < 0 then q
+             else Q i (L.adjust f idx xs) ys j
+  | otherwise = let k' = j - (idx - i) - 1
+                in if k' < 0 then q
+                   else Q i xs (L.adjust f k' ys) j
+
+{-
+could do
+  mapWithIndex   :: (Int -> a -> b) -> s a -> s b
+  foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b
+  foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b
+but don't bother for now
+-}
+
+take len q@(Q i xs ys j) =
+  if len <= i then
+    if len <= 0 then empty
+    else Q len (L.take len xs) [] 0
+  else let len' = len - i in
+    if len' >= j then q
+    else Q i xs (L.drop (j - len') ys) len'
+
+drop len q@(Q i xs ys j) =
+  if len <= i then
+    if len <= 0 then q
+    else makeQ (i - len) (L.drop len xs) ys j
+  else let len' = len - i in
+    if len' >= j then empty
+    else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0
+  -- could write more efficient version of reverse (take ...)
+
+splitAt idx q@(Q i xs ys j) =
+  if idx <= i then
+    if idx <= 0 then (empty, q)
+    else let (xs',xs'') = L.splitAt idx xs
+         in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j)
+  else let idx' = idx - i in
+    if idx' >= j then (q, empty)
+    else let (ys', ys'') = L.splitAt (j - idx') ys
+         in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0)
+      -- could do splitAt followed by reverse more efficiently...
+
+
+strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l
+strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l
+
+-- the remaining functions all use defaults
+
+concat = concatUsingFoldr
+concatMap = concatMapUsingFoldr
+reducer = reducerUsingReduce1
+reducel = reducelUsingReduce1
+reduce1 = reduce1UsingLists
+reducer' = reducer'UsingReduce1'
+reducel' = reducel'UsingReduce1'
+reduce1' = reduce1'UsingLists
+inBounds = inBoundsUsingSize
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+subseq = subseqDefault
+filter = filterUsingLists
+partition = partitionUsingLists
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+zip = zipUsingLists
+zip3 = zip3UsingLists
+zipWith = zipWithUsingLists
+zipWith3 = zipWith3UsingLists
+unzip = unzipUsingLists
+unzip3 = unzip3UsingLists
+unzipWith = unzipWithUsingLists
+unzipWith3 = unzipWith3UsingLists
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer';
+   reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;
+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Eq a => Eq (Seq a) where
+  q1 == q2 =
+    (size q1 == size q2) && (toList q1 == toList q2)
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary =
+    do xs <- arbitrary
+       ys <- arbitrary
+       return (let i = L.size xs
+                   j = L.size ys
+               in if i >= j then Q i xs ys j else Q j ys xs i)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary (Q _ xs ys _) = coarbitrary xs . coarbitrary ys
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/BinaryRandList.hs view

@@ -1,468 +1,468 @@--- |---   Module      :  Data.Edison.Seq.BinaryRandList---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Binary Random-Access lists.  All functions have the standard running---   times from "Data.Edison.Seq" except the following:------  * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop   @O( log n )@------  * copy, inBounds   @O( i )@------  * append, reverseOnto  @O( n1 + log n2 )@------  * take, splitAt  @O( i + log n )@------  * subseq         @O( log n + len )@------  * zip            @O( min( n1, n2 ) + log max( n1, n2 ) )@------    /References:/------  * Chris Okasaki. /Purely Functional Data Structures/. 1998.---    Section 10.1.2.--module Data.Edison.Seq.BinaryRandList (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App-import Data.Maybe--import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BinaryRandList"---data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a))    deriving (Eq)---- not exported, rewrite as bit ops?---even n = (n `mod` 2) == 0---odd n  = (n `mod` 2) <> 0-half :: (Integral a) => a -> a-half n = n `div` 2--mkEven :: Seq (a, a) -> Seq a-mkEven E = E-mkEven ps = Even ps--empty = E-singleton x = Odd x E--lcons x E = Odd x E-lcons x (Even ps) = Odd x ps-lcons x (Odd y ps) = Even (lcons (x,y) ps)--append xs E = xs-append xs ys@(Even pys) =-  case xs of-    E -> ys-    Even pxs -> Even (append pxs pys)-    Odd x pxs -> Odd x (append pxs pys)-append xs ys@(Odd _ _) = foldr lcons ys xs--copy n x-    | n <= 0 = E-    | otherwise = cp n x-  where cp :: Int -> a -> Seq a-        cp n x-          | odd n = Odd x (cp (half n) (x,x))-          | n == 0 = E-          | otherwise = Even (cp (half n) (x,x))--lview E = fail "BinaryRandList.lview: empty sequence"-lview (Even ps) = case lview ps of-                    Just ((x,y), ps') -> return (x, Odd y ps')-                    Nothing -> error "BinaryRandList.lview: bug!"-lview (Odd x ps) = return (x, mkEven ps)--lhead E = error "BinaryRandList.lhead: empty sequence"-lhead (Even ps) = fst (lhead ps)-lhead (Odd x _) = x--lheadM E = fail "BinaryRandList.lheadM: empty sequence"-lheadM (Even ps) = return (fst (lhead ps))-lheadM (Odd x _) = return (x)--ltail E = error "BinaryRandList.ltail: empty sequence"-ltail (Even ps) = case lview ps of-                    Just ((_,y), ps') -> Odd y ps'-                    Nothing -> error "BinaryRandList.ltail: bug!"-ltail (Odd _ ps) = mkEven ps--ltailM E = fail "BinaryRandList.ltailM: empty sequence"-ltailM (Even ps) = case lview ps of-                      Just ((_,y), ps') -> return (Odd y ps')-                      Nothing -> error "BinaryRandList.ltailM: bug!"-ltailM (Odd _ ps) = return (mkEven ps)--rhead E = error "BinaryRandList.rhead: empty sequence"-rhead (Even ps) = snd (rhead ps)-rhead (Odd x E) = x-rhead (Odd _ ps) = snd (rhead ps)--rheadM E = fail "BinaryRandList.rheadM: empty sequence"-rheadM (Even ps) = return (snd (rhead ps))-rheadM (Odd x E) = return x-rheadM (Odd _ ps) = return (snd (rhead ps))---null E = True-null _ = False--size E = 0-size (Even ps) = 2 * size ps-size (Odd _ ps) = 1 + 2 * size ps--map _ E = E-map f (Even ps)  = Even (map (\(x,y) -> (f x,f y)) ps)-map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps)--fold   = foldr-fold'  = foldr'-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (Even ps)  = foldr (\(x,y) e -> f x (f y e)) e ps-foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps)--foldr' _ e E = e-foldr' f e (Even ps)  = foldr' (\(x,y) e -> f x $! f y $! e) e ps-foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps)--foldl _ e E = e-foldl f e (Even ps)  = foldl (\e (x,y) -> f (f e x) y) e ps-foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps--foldl' _ e E = e-foldl' f e (Even ps)  = foldl' (\e (x,y) -> f (f e x) y) e ps-foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps--reduce1 _ E = error "BinaryRandList.reduce1: empty seq"-reduce1 f (Even ps)  = reduce1 f (map (uncurry f) ps)-reduce1 _ (Odd x E)  = x-reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps))--reduce1' _ E = error "BinaryRandList.reduce1': empty seq"-reduce1' f (Even ps)  = reduce1' f (map (uncurry f) ps)-reduce1' _ (Odd x E)  = x-reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps))---inBounds i xs = (i >= 0) && inb xs i-  where inb :: Seq a -> Int -> Bool-        inb E _ = False-        inb (Even ps) i = inb ps (half i)-        inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1))--lookup i xs = runFail_ (lookupM i xs)--lookupM i xs-    | i < 0     = fail "BinaryRandList.lookup: bad subscript"-    | otherwise = lookFun nothing xs i return-    where-        nothing = fail "BinaryRandList.lookup: not found"--lookupWithDefault d i xs-    | i < 0 = d-    | otherwise = lookFun d xs i id---- not exported-lookFun :: b -> Seq a -> Int -> (a -> b) -> b-lookFun d E _ _ = d-lookFun d (Even ps) i f-  | even i = lookFun d ps (half i) (f . fst)-  | otherwise = lookFun d ps (half i) (f . snd)-lookFun d (Odd x ps) i f-  | odd i = lookFun d ps (half (i-1)) (f . fst)-  | i == 0 = f x-  | otherwise = lookFun d ps (half (i-1)) (f . snd)--adjust f i xs-    | i < 0 = xs-    | otherwise = adj f i xs-  where adj :: (a -> a) -> Int -> Seq a -> Seq a-        adj _ _ E = E-        adj f i (Even ps)-          | even i = Even (adj (mapFst f) (half i) ps)-          | otherwise = Even (adj (mapSnd f) (half i) ps)-        adj f i (Odd x ps)-          | odd i = Odd x (adj (mapFst f) (half (i-1)) ps)-          | i == 0 = Odd (f x) ps-          | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps)---- not exported-mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)-mapFst f (x,y) = (f x,y)-mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)-mapSnd f (x,y) = (x,f y)--take n xs = if n <= 0 then E else tak n xs-  where tak :: Int -> Seq a -> Seq a-        tak 0 _ = E-        tak _ E = E-        tak i (Even ps)-          | even i = Even (tak (half i) ps)-        tak i (Odd x ps)-          | odd i = Odd x (tak (half (i-1)) ps)-        tak i xs = takeUsingLists i xs---- drop is O(log^2 n) instead of O(log n)??-drop n xs = if n <= 0 then xs else drp n xs-  where drp :: Int -> Seq a -> Seq a-        drp 0 xs = xs-        drp _ E = E-        drp i (Even ps)-          | even i = mkEven (drp (half i) ps)-          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps)))-        drp i (Odd _ ps)-          | odd i = mkEven (drp (half (i-1)) ps)-          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps)))---strict l@E = l-strict l@(Even l') = strict l' `seq` l-strict l@(Odd _ l') = strict l' `seq` l--strictWith _ l@E = l-strictWith f l@(Even l')  = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l-strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l----- structural invariants are enforced by the type system-structuralInvariant = const True---- the remaining functions all use defaults--rcons = rconsUsingFoldr-rview = rviewDefault-rtail = rtailUsingLview-rtailM = rtailMUsingLview-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-reverseOnto = reverseOntoUsingFoldl-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-foldr1 = foldr1UsingLview-foldr1' = foldr1'UsingLview-foldl1 = foldl1UsingFoldl-foldl1' = foldl1'UsingFoldl'-reducer = reducerUsingReduce1-reducel = reducelUsingReduce1-reducer' = reducer'UsingReduce1'-reducel' = reducel'UsingReduce1'-update = updateUsingAdjust-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty---- instance Eq (Seq a) is derived--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = do xs <- arbitrary-                 return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary E = variant 0-  coarbitrary (Even ps) = variant 1 . coarbitrary ps-  coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps---instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.BinaryRandList
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Binary Random-Access lists.  All functions have the standard running
+--   times from "Data.Edison.Seq" except the following:
+--
+--  * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop   @O( log n )@
+--
+--  * copy, inBounds   @O( i )@
+--
+--  * append, reverseOnto  @O( n1 + log n2 )@
+--
+--  * take, splitAt  @O( i + log n )@
+--
+--  * subseq         @O( log n + len )@
+--
+--  * zip            @O( min( n1, n2 ) + log max( n1, n2 ) )@
+--
+--    /References:/
+--
+--  * Chris Okasaki. /Purely Functional Data Structures/. 1998.
+--    Section 10.1.2.
+
+module Data.Edison.Seq.BinaryRandList (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+import Data.Maybe
+
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.BinaryRandList"
+
+
+data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a))    deriving (Eq)
+
+-- not exported, rewrite as bit ops?
+--even n = (n `mod` 2) == 0
+--odd n  = (n `mod` 2) <> 0
+half :: (Integral a) => a -> a
+half n = n `div` 2
+
+mkEven :: Seq (a, a) -> Seq a
+mkEven E = E
+mkEven ps = Even ps
+
+empty = E
+singleton x = Odd x E
+
+lcons x E = Odd x E
+lcons x (Even ps) = Odd x ps
+lcons x (Odd y ps) = Even (lcons (x,y) ps)
+
+append xs E = xs
+append xs ys@(Even pys) =
+  case xs of
+    E -> ys
+    Even pxs -> Even (append pxs pys)
+    Odd x pxs -> Odd x (append pxs pys)
+append xs ys@(Odd _ _) = foldr lcons ys xs
+
+copy n x
+    | n <= 0 = E
+    | otherwise = cp n x
+  where cp :: Int -> a -> Seq a
+        cp n x
+          | odd n = Odd x (cp (half n) (x,x))
+          | n == 0 = E
+          | otherwise = Even (cp (half n) (x,x))
+
+lview E = fail "BinaryRandList.lview: empty sequence"
+lview (Even ps) = case lview ps of
+                    Just ((x,y), ps') -> return (x, Odd y ps')
+                    Nothing -> error "BinaryRandList.lview: bug!"
+lview (Odd x ps) = return (x, mkEven ps)
+
+lhead E = error "BinaryRandList.lhead: empty sequence"
+lhead (Even ps) = fst (lhead ps)
+lhead (Odd x _) = x
+
+lheadM E = fail "BinaryRandList.lheadM: empty sequence"
+lheadM (Even ps) = return (fst (lhead ps))
+lheadM (Odd x _) = return (x)
+
+ltail E = error "BinaryRandList.ltail: empty sequence"
+ltail (Even ps) = case lview ps of
+                    Just ((_,y), ps') -> Odd y ps'
+                    Nothing -> error "BinaryRandList.ltail: bug!"
+ltail (Odd _ ps) = mkEven ps
+
+ltailM E = fail "BinaryRandList.ltailM: empty sequence"
+ltailM (Even ps) = case lview ps of
+                      Just ((_,y), ps') -> return (Odd y ps')
+                      Nothing -> error "BinaryRandList.ltailM: bug!"
+ltailM (Odd _ ps) = return (mkEven ps)
+
+rhead E = error "BinaryRandList.rhead: empty sequence"
+rhead (Even ps) = snd (rhead ps)
+rhead (Odd x E) = x
+rhead (Odd _ ps) = snd (rhead ps)
+
+rheadM E = fail "BinaryRandList.rheadM: empty sequence"
+rheadM (Even ps) = return (snd (rhead ps))
+rheadM (Odd x E) = return x
+rheadM (Odd _ ps) = return (snd (rhead ps))
+
+
+null E = True
+null _ = False
+
+size E = 0
+size (Even ps) = 2 * size ps
+size (Odd _ ps) = 1 + 2 * size ps
+
+map _ E = E
+map f (Even ps)  = Even (map (\(x,y) -> (f x,f y)) ps)
+map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps)
+
+fold   = foldr
+fold'  = foldr'
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr _ e E = e
+foldr f e (Even ps)  = foldr (\(x,y) e -> f x (f y e)) e ps
+foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps)
+
+foldr' _ e E = e
+foldr' f e (Even ps)  = foldr' (\(x,y) e -> f x $! f y $! e) e ps
+foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps)
+
+foldl _ e E = e
+foldl f e (Even ps)  = foldl (\e (x,y) -> f (f e x) y) e ps
+foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps
+
+foldl' _ e E = e
+foldl' f e (Even ps)  = foldl' (\e (x,y) -> f (f e x) y) e ps
+foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps
+
+reduce1 _ E = error "BinaryRandList.reduce1: empty seq"
+reduce1 f (Even ps)  = reduce1 f (map (uncurry f) ps)
+reduce1 _ (Odd x E)  = x
+reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps))
+
+reduce1' _ E = error "BinaryRandList.reduce1': empty seq"
+reduce1' f (Even ps)  = reduce1' f (map (uncurry f) ps)
+reduce1' _ (Odd x E)  = x
+reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps))
+
+
+inBounds i xs = (i >= 0) && inb xs i
+  where inb :: Seq a -> Int -> Bool
+        inb E _ = False
+        inb (Even ps) i = inb ps (half i)
+        inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1))
+
+lookup i xs = runFail_ (lookupM i xs)
+
+lookupM i xs
+    | i < 0     = fail "BinaryRandList.lookup: bad subscript"
+    | otherwise = lookFun nothing xs i return
+    where
+        nothing = fail "BinaryRandList.lookup: not found"
+
+lookupWithDefault d i xs
+    | i < 0 = d
+    | otherwise = lookFun d xs i id
+
+-- not exported
+lookFun :: b -> Seq a -> Int -> (a -> b) -> b
+lookFun d E _ _ = d
+lookFun d (Even ps) i f
+  | even i = lookFun d ps (half i) (f . fst)
+  | otherwise = lookFun d ps (half i) (f . snd)
+lookFun d (Odd x ps) i f
+  | odd i = lookFun d ps (half (i-1)) (f . fst)
+  | i == 0 = f x
+  | otherwise = lookFun d ps (half (i-1)) (f . snd)
+
+adjust f i xs
+    | i < 0 = xs
+    | otherwise = adj f i xs
+  where adj :: (a -> a) -> Int -> Seq a -> Seq a
+        adj _ _ E = E
+        adj f i (Even ps)
+          | even i = Even (adj (mapFst f) (half i) ps)
+          | otherwise = Even (adj (mapSnd f) (half i) ps)
+        adj f i (Odd x ps)
+          | odd i = Odd x (adj (mapFst f) (half (i-1)) ps)
+          | i == 0 = Odd (f x) ps
+          | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps)
+
+-- not exported
+mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)
+mapFst f (x,y) = (f x,y)
+mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)
+mapSnd f (x,y) = (x,f y)
+
+take n xs = if n <= 0 then E else tak n xs
+  where tak :: Int -> Seq a -> Seq a
+        tak 0 _ = E
+        tak _ E = E
+        tak i (Even ps)
+          | even i = Even (tak (half i) ps)
+        tak i (Odd x ps)
+          | odd i = Odd x (tak (half (i-1)) ps)
+        tak i xs = takeUsingLists i xs
+
+-- drop is O(log^2 n) instead of O(log n)??
+drop n xs = if n <= 0 then xs else drp n xs
+  where drp :: Int -> Seq a -> Seq a
+        drp 0 xs = xs
+        drp _ E = E
+        drp i (Even ps)
+          | even i = mkEven (drp (half i) ps)
+          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps)))
+        drp i (Odd _ ps)
+          | odd i = mkEven (drp (half (i-1)) ps)
+          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps)))
+
+
+strict l@E = l
+strict l@(Even l') = strict l' `seq` l
+strict l@(Odd _ l') = strict l' `seq` l
+
+strictWith _ l@E = l
+strictWith f l@(Even l')  = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l
+strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l
+
+
+-- structural invariants are enforced by the type system
+structuralInvariant = const True
+
+-- the remaining functions all use defaults
+
+rcons = rconsUsingFoldr
+rview = rviewDefault
+rtail = rtailUsingLview
+rtailM = rtailMUsingLview
+concat = concatUsingFoldr
+reverse = reverseUsingReverseOnto
+reverseOnto = reverseOntoUsingFoldl
+fromList = fromListUsingCons
+toList = toListUsingFoldr
+concatMap = concatMapUsingFoldr
+foldr1 = foldr1UsingLview
+foldr1' = foldr1'UsingLview
+foldl1 = foldl1UsingFoldl
+foldl1' = foldl1'UsingFoldl'
+reducer = reducerUsingReduce1
+reducel = reducelUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel' = reducel'UsingReduce1'
+update = updateUsingAdjust
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex = foldrWithIndexUsingLists
+foldlWithIndex = foldlWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+splitAt = splitAtDefault
+filter = filterUsingFoldr
+partition = partitionUsingFoldr
+subseq = subseqDefault
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+
+-- for zips, could optimize by calculating which one is shorter and
+-- retaining its shape
+
+zip = zipUsingLists
+zip3 = zip3UsingLists
+zipWith = zipWithUsingLists
+zipWith3 = zipWith3UsingLists
+unzip = unzipUsingLists
+unzip3 = unzip3UsingLists
+unzipWith = unzipWithUsingLists
+unzipWith3 = unzipWith3UsingLists
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+-- instance Eq (Seq a) is derived
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = do xs <- arbitrary
+                 return (fromList xs)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (Even ps) = variant (1 :: Int) . coarbitrary ps
+  coarbitrary (Odd x ps) = variant (2 :: Int) . coarbitrary x . coarbitrary ps
+
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/BraunSeq.hs view

@@ -1,570 +1,567 @@--- |---   Module      :  Data.Edison.Seq.BraunSeq---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   One-sided Braun sequences.  All running times are as listed in---   "Data.Edison.Seq" except the following:------   * lview, lcons, ltail*   @O( log n )@------   * rcons, rview, rhead*, rtail*, size   @O( log^2 n )@------   * copy, inBounds, lookup*, update, adjust  @O( log i )@------   * append            @O( n1 log n2 )@------   * concat            @O( n + m log m )@------   * drop, splitAt     @O( i log n )@------   * subseq            @O( i log n + len )@------   * reverseOnto       @O( n1 log n2 )@------   * concatMap, (>>=)  @O( n * t + m log m )@, where @n@ is the length of the input sequence---                                               @m@ is the length of the output sequence and @t@---                                               is the running time of @f@------   By keeping track of the size, we could get rcons, rview, rhead*, and rtail*---   down to @O(log n)@ as well; furthermore, size would be @O( 1 )@.------   /References:/------   * Rob Hoogerwoord. \"A symmetric set of efficient list operations\".---     /Journal of Functional Programming/, 2(4):505--513, 1992.------   * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\".---     /Mathematics of Program Construction/ (MPC'92), pages 191-207.------   * Chris Okasaki. \"Three algorithms on Braun Trees\".---     /Journal of Function Programming/ 7(6):661-666. Novemebr 1997.--module Data.Edison.Seq.BraunSeq (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Maybe-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck---import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L----- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BraunSeq"---data Seq a = E | B a (Seq a) (Seq a)    deriving (Eq)--half :: Int -> Int-half n = n `quot` 2  -- use a shift?--empty = E-singleton x = B x E E--lcons x E = singleton x-lcons x (B y a b) = B x (lcons y b) a--rcons y ys = insAt (size ys) ys-  where insAt 0 _ = singleton y-        insAt i (B x a b)-          | odd i     = B x (insAt (half i) a) b-          | otherwise = B x a (insAt (half i - 1) b)-        insAt _ _ = error "BraunSeq.rcons: bug.  Impossible case!"--append xs E = xs-append xs ys = app (size xs) xs ys-  where app 0 _ ys = ys-        app _ xs E = xs-        app n (B x a b) (B y c d)-            | odd n     = B x (app m a (lcons y d)) (app m b c)-            | otherwise = B x (app m a c) (app (m-1) b (lcons y d))-          where m = half n-        app _ _ _ = error "BraunSeq.append: bug!"-  -- how does it compare to converting to/from lists?--lview E = fail "BraunSeq.lview: empty sequence"-lview (B x a b) = return (x, combine a b)---- not exported-combine :: Seq a -> Seq a -> Seq a-combine E _ = E-combine (B x a b) c = B x c (combine a b)--lhead E = error "BraunSeq.lhead: empty sequence"-lhead (B x _ _) = x--lheadM E = fail "BraunSeq.lheadM: empty sequence"-lheadM (B x _ _) = return x--ltail E = error "BraunSeq.ltail: empty sequence"-ltail (B _ a b) = combine a b--ltailM E = fail "BraunSeq.ltailM: empty sequence"-ltailM (B _ a b) = return (combine a b)---- not exported--- precondition: i >= 0-delAt :: Int -> Seq a -> Seq a-delAt 0 _ = E-delAt i (B x a b)-  | odd i     = B x (delAt (half i) a) b-  | otherwise = B x a (delAt (half i - 1) b)-delAt _ _ = error "BraunSeq.delAt: bug.  Impossible case!"--rview E = fail "BraunSeq.rview: empty sequence"-rview xs = return (lookup m xs, delAt m xs)-  where m = size xs - 1--rhead E = error "BraunSeq.rhead: empty sequence"-rhead xs = lookup (size xs - 1) xs--rheadM E = fail  "BraunSeq.rheadM: empty sequence"-rheadM xs = return (lookup (size xs - 1) xs)--rtail E = error "BraunSeq.rtail: empty sequence"-rtail xs = delAt (size xs - 1) xs--rtailM E = fail "BraunSeq.rtailM: empty sequence"-rtailM xs = return (delAt (size xs - 1) xs)--null E = True-null _ = False--size E = 0-size (B _ a b) = 1 + n + n + diff n a-  where n = size b--        diff 0 E = 0-        diff 0 (B _ _ _) = 1-        diff i (B _ a b)-          | odd i     = diff (half i) a-          | otherwise = diff (half i - 1) b-        diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!"--reverse xs = rev00 (size xs) xs-  where-    rev00 n xs-      | n <= 1 = xs-    rev00 n (B x a b)-      | odd n     = let a'      = rev00 m a-                        (x',b') = rev11 m x b      in B x' a' b'-      | otherwise = let (x',a') = rev01 m a-                        b'      = rev10 (m-1) x b  in B x' b' a'-      where m = half n-    rev00 _ _ = error "BraunSeq.reverse: bug!"--    rev11 _ x E = (x,E)-    rev11 n x (B y a b)-      | odd n     = let (x',a') = rev11 m x a-                        (y',b') = rev11 m y b      in (y', B x' b' a')-      | otherwise = let (x',a') = rev11 m x a-                        (y',b') = rev11 (m-1) y b  in (x', B y' a' b')-      where m = half n--    rev01 _ E = error "BraunSeq.reverse: bug!"-    rev01 n (B x a b)-      | n == 1    = (x, E)-      | odd n     = let (y',a') = rev01 m a-                        (x',b') = rev11 m x b      in (x', B y' b' a')-      | otherwise = let (y',a') = rev01 m a-                        (x',b') = rev11 (m-1) x b  in (y', B x' a' b')-      where m = half n--    rev10 _ x E = B x E E-    rev10 n x (B y a b)-      | odd n     = let a'      = rev10 m x a-                        (y',b') = rev11 m y b      in B y' a' b'-      | otherwise = let (x',a') = rev11 m x a-                        b'      = rev10 (m-1) y b  in B x' b' a'-      where m = half n--fromList = L.lhead . L.foldr build [E] . rows 1-  where rows _ [] = []-        rows k xs = (k, ys) : rows (k+k) zs-          where (ys,zs) = L.splitAt k xs--        build (k,xs) ts = zipWithB xs ts1 ts2-          where (ts1, ts2) = L.splitAt k ts--        zipWithB [] _ _ = []-        zipWithB (x:xs) [] _ = singleton x : L.map singleton xs-        zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts []-        zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2--toList E = []-toList t = tol [t]-  where tol [] = []-        tol ts = xs ++ tol (ts1 ++ ts2)-          where xs = L.map root ts-                (ts1,ts2) = children ts--                children [] = ([],[])-                children (B _ E _ : _) = ([],[])-                children (B _ a E : ts) = (a : leftChildren ts, [])-                children (B _ a b : ts) = (a : ts1, b : ts2)-                  where (ts1, ts2) = children ts-                children _ = error "BraunSeq.toList: bug!"--                leftChildren [] = []-                leftChildren (B _ E _ : _) = []-                leftChildren (B _ a _ : ts) = a : leftChildren ts-                leftChildren _ = error "BraunSeq.toList: bug!"--                root (B x _ _) = x-                root _ = error "BraunSeq.toList: bug!"--                (B _ a _) = a---                (left _) = error "BraunSeq.toList: bug!"--map _ E = E-map f (B x a b) = B (f x) (map f a) (map f b)--copy n x = if n <= 0 then empty else fst (copy2 n)-  where copy2 n-            | odd n     = (B x a a, B x b a)-            | n == 0    = (E, singleton x)-            | otherwise = (B x b a, B x b b)-          where (a, b) = copy2 (half (n-1))--inBounds i xs = (i >= 0) && inb xs i-  where inb E _ = False-        inb (B _ a b) i-          | odd i     = inb a (half i)-          | i == 0    = True-          | otherwise = inb b (half i - 1)--lookup i xs = runFail_ (lookupM i xs)--lookupM i xs-  | i < 0     = fail "BraunSeq.lookupM: bad subscript"-  | otherwise = look xs i-  where look E _ = nothing-        look (B x a b) i-          | odd i     = look a (half i)-          | i == 0    = return x-          | otherwise = look b (half i - 1)-        nothing = fail "BraunSeq.lookupM: not found"--lookupWithDefault d i xs = if i < 0 then d-                           else look xs i-  where look E _ = d-        look (B x a b) i-          | odd i     = look a (half i)-          | i == 0    = x-          | otherwise = look b (half i - 1)--update i y xs = if i < 0 then xs else upd i xs-  where upd _ E = E-        upd i (B x a b)-          | odd i     = B x (upd (half i) a) b-          | i == 0    = B y a b-          | otherwise = B x a (upd (half i - 1) b)--adjust f i xs = if i < 0 then xs else adj i xs-  where adj _ E = E-        adj i (B x a b)-          | odd i     = B x (adj (half i) a) b-          | i == 0    = B (f x) a b-          | otherwise = B x a (adj (half i - 1) b)--mapWithIndex f xs = mwi 0 1 xs-  where mwi _ _ E = E-        mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b)-          where dd = d+d--take n xs = if n <= 0 then E else ta n xs-  where ta _ E = E-        ta n (B x a b)-            | odd n     = B x (ta m a) (ta m b)-            | n == 0    = E-            | otherwise = B x (ta m a) (ta (m-1) b)-          where m = half n--drop n xs = if n <= 0 then xs else dr n xs-  where dr _ E = E-        dr n t@(B _ a b)-            | odd n     = combine (dr m a) (dr m b)-            | n == 0    = t-            | otherwise = combine (dr (m-1) b) (dr m a)-          where m = half n--zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d)-zip _ _ = E--zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f)-zip3 _ _ _ = E--zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d)-zipWith _ _ _ = E--zipWith3 fn (B x a b) (B y c d) (B z e f) =-    B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f)-zipWith3 _ _ _ _ = E--unzip E = (E, E)-unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2)-  where (a1,a2) = unzip a-        (b1,b2) = unzip b--unzip3 E = (E, E, E)-unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3)-  where (a1,a2,a3) = unzip3 a-        (b1,b2,b3) = unzip3 b--unzipWith _ _ E = (E, E)-unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2)-  where (a1,a2) = unzipWith f g a-        (b1,b2) = unzipWith f g b--unzipWith3 _ _ _ E = (E, E, E)-unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3)-  where (a1,a2,a3) = unzipWith3 f g h a-        (b1,b2,b3) = unzipWith3 f g h b---strict s@E = s-strict s@(B _ l r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s---- invariants:---   * Left subtree is exactily the same size as the right---     subtree, or one element larger---- structuralInvariant :: Seq a -> Bool-structuralInvariant E         = True-structuralInvariant (B _ l r) = isJust (check l r)--  where check :: Seq a -> Seq a -> Maybe Int-        check E           E           = Just 1-        check (B _ E E)   E           = Just 2-        check (B _ l1 l2) (B _ r1 r2) = do-           x <- check l1 l2-           y <- check r1 r2-           if (x == y) || (x == y + 1)-              then return (x+y+1)-              else fail "unbalanced tree"-        check _ _ = fail "unbalanced tree"----- the remaining functions all use defaults--concat = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-concatMap = concatMapUsingFoldr-fold = foldrUsingLists-fold' f = foldl'UsingLists (flip f)-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'-foldr = foldrUsingLists-foldr' = foldr'UsingLists-foldl = foldlUsingLists-foldl' = foldl'UsingLists-foldr1 = foldr1UsingLists-foldr1' = foldr1'UsingLists-foldl1 = foldl1UsingLists-foldl1' = foldl1UsingLists-reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1 = reduce1UsingLists-reduce1' = reduce1'UsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-splitAt = splitAtDefault-subseq = subseqDefault-filter = filterUsingLists-partition = partitionUsingLists-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview----- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty---- instance Eq (Seq a) is derived--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = arbitrary >>= (return . fromList)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary xs = coarbitrary (toList xs)--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.BraunSeq
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   One-sided Braun sequences.  All running times are as listed in
+--   "Data.Edison.Seq" except the following:
+--
+--   * lview, lcons, ltail*   @O( log n )@
+--
+--   * rcons, rview, rhead*, rtail*, size   @O( log^2 n )@
+--
+--   * copy, inBounds, lookup*, update, adjust  @O( log i )@
+--
+--   * append            @O( n1 log n2 )@
+--
+--   * concat            @O( n + m log m )@
+--
+--   * drop, splitAt     @O( i log n )@
+--
+--   * subseq            @O( i log n + len )@
+--
+--   * reverseOnto       @O( n1 log n2 )@
+--
+--   * concatMap, (>>=)  @O( n * t + m log m )@, where @n@ is the length of the input sequence
+--                                               @m@ is the length of the output sequence and @t@
+--                                               is the running time of @f@
+--
+--   By keeping track of the size, we could get rcons, rview, rhead*, and rtail*
+--   down to @O(log n)@ as well; furthermore, size would be @O( 1 )@.
+--
+--   /References:/
+--
+--   * Rob Hoogerwoord. \"A symmetric set of efficient list operations\".
+--     /Journal of Functional Programming/, 2(4):505--513, 1992.
+--
+--   * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\".
+--     /Mathematics of Program Construction/ (MPC'92), pages 191-207.
+--
+--   * Chris Okasaki. \"Three algorithms on Braun Trees\".
+--     /Journal of Function Programming/ 7(6):661-666. Novemebr 1997.
+
+module Data.Edison.Seq.BraunSeq (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Maybe
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import qualified Data.Edison.Seq.ListSeq as L
+
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.BraunSeq"
+
+
+data Seq a = E | B a (Seq a) (Seq a)    deriving (Eq)
+
+half :: Int -> Int
+half n = n `quot` 2  -- use a shift?
+
+empty = E
+singleton x = B x E E
+
+lcons x E = singleton x
+lcons x (B y a b) = B x (lcons y b) a
+
+rcons y ys = insAt (size ys) ys
+  where insAt 0 _ = singleton y
+        insAt i (B x a b)
+          | odd i     = B x (insAt (half i) a) b
+          | otherwise = B x a (insAt (half i - 1) b)
+        insAt _ _ = error "BraunSeq.rcons: bug.  Impossible case!"
+
+append xs E = xs
+append xs ys = app (size xs) xs ys
+  where app 0 _ ys = ys
+        app _ xs E = xs
+        app n (B x a b) (B y c d)
+            | odd n     = B x (app m a (lcons y d)) (app m b c)
+            | otherwise = B x (app m a c) (app (m-1) b (lcons y d))
+          where m = half n
+        app _ _ _ = error "BraunSeq.append: bug!"
+  -- how does it compare to converting to/from lists?
+
+lview E = fail "BraunSeq.lview: empty sequence"
+lview (B x a b) = return (x, combine a b)
+
+-- not exported
+combine :: Seq a -> Seq a -> Seq a
+combine E _ = E
+combine (B x a b) c = B x c (combine a b)
+
+lhead E = error "BraunSeq.lhead: empty sequence"
+lhead (B x _ _) = x
+
+lheadM E = fail "BraunSeq.lheadM: empty sequence"
+lheadM (B x _ _) = return x
+
+ltail E = error "BraunSeq.ltail: empty sequence"
+ltail (B _ a b) = combine a b
+
+ltailM E = fail "BraunSeq.ltailM: empty sequence"
+ltailM (B _ a b) = return (combine a b)
+
+-- not exported
+-- precondition: i >= 0
+delAt :: Int -> Seq a -> Seq a
+delAt 0 _ = E
+delAt i (B x a b)
+  | odd i     = B x (delAt (half i) a) b
+  | otherwise = B x a (delAt (half i - 1) b)
+delAt _ _ = error "BraunSeq.delAt: bug.  Impossible case!"
+
+rview E = fail "BraunSeq.rview: empty sequence"
+rview xs = return (lookup m xs, delAt m xs)
+  where m = size xs - 1
+
+rhead E = error "BraunSeq.rhead: empty sequence"
+rhead xs = lookup (size xs - 1) xs
+
+rheadM E = fail  "BraunSeq.rheadM: empty sequence"
+rheadM xs = return (lookup (size xs - 1) xs)
+
+rtail E = error "BraunSeq.rtail: empty sequence"
+rtail xs = delAt (size xs - 1) xs
+
+rtailM E = fail "BraunSeq.rtailM: empty sequence"
+rtailM xs = return (delAt (size xs - 1) xs)
+
+null E = True
+null _ = False
+
+size E = 0
+size (B _ a b) = 1 + n + n + diff n a
+  where n = size b
+
+        diff 0 E = 0
+        diff 0 (B _ _ _) = 1
+        diff i (B _ a b)
+          | odd i     = diff (half i) a
+          | otherwise = diff (half i - 1) b
+        diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!"
+
+reverse xs = rev00 (size xs) xs
+  where
+    rev00 n xs
+      | n <= 1 = xs
+    rev00 n (B x a b)
+      | odd n     = let a'      = rev00 m a
+                        (x',b') = rev11 m x b      in B x' a' b'
+      | otherwise = let (x',a') = rev01 m a
+                        b'      = rev10 (m-1) x b  in B x' b' a'
+      where m = half n
+    rev00 _ _ = error "BraunSeq.reverse: bug!"
+
+    rev11 _ x E = (x,E)
+    rev11 n x (B y a b)
+      | odd n     = let (x',a') = rev11 m x a
+                        (y',b') = rev11 m y b      in (y', B x' b' a')
+      | otherwise = let (x',a') = rev11 m x a
+                        (y',b') = rev11 (m-1) y b  in (x', B y' a' b')
+      where m = half n
+
+    rev01 _ E = error "BraunSeq.reverse: bug!"
+    rev01 n (B x a b)
+      | n == 1    = (x, E)
+      | odd n     = let (y',a') = rev01 m a
+                        (x',b') = rev11 m x b      in (x', B y' b' a')
+      | otherwise = let (y',a') = rev01 m a
+                        (x',b') = rev11 (m-1) x b  in (y', B x' a' b')
+      where m = half n
+
+    rev10 _ x E = B x E E
+    rev10 n x (B y a b)
+      | odd n     = let a'      = rev10 m x a
+                        (y',b') = rev11 m y b      in B y' a' b'
+      | otherwise = let (x',a') = rev11 m x a
+                        b'      = rev10 (m-1) y b  in B x' b' a'
+      where m = half n
+
+fromList = L.lhead . L.foldr build [E] . rows 1
+  where rows _ [] = []
+        rows k xs = (k, ys) : rows (k+k) zs
+          where (ys,zs) = L.splitAt k xs
+
+        build (k,xs) ts = zipWithB xs ts1 ts2
+          where (ts1, ts2) = L.splitAt k ts
+
+        zipWithB [] _ _ = []
+        zipWithB (x:xs) [] _ = singleton x : L.map singleton xs
+        zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts []
+        zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2
+
+toList E = []
+toList t = tol [t]
+  where tol [] = []
+        tol ts = xs ++ tol (ts1 ++ ts2)
+          where xs = L.map root ts
+                (ts1,ts2) = children ts
+
+                children [] = ([],[])
+                children (B _ E _ : _) = ([],[])
+                children (B _ a E : ts) = (a : leftChildren ts, [])
+                children (B _ a b : ts) = (a : ts1, b : ts2)
+                  where (ts1, ts2) = children ts
+                children _ = error "BraunSeq.toList: bug!"
+
+                leftChildren [] = []
+                leftChildren (B _ E _ : _) = []
+                leftChildren (B _ a _ : ts) = a : leftChildren ts
+                leftChildren _ = error "BraunSeq.toList: bug!"
+
+                root (B x _ _) = x
+                root _ = error "BraunSeq.toList: bug!"
+
+map _ E = E
+map f (B x a b) = B (f x) (map f a) (map f b)
+
+copy n x = if n <= 0 then empty else fst (copy2 n)
+  where copy2 n
+            | odd n     = (B x a a, B x b a)
+            | n == 0    = (E, singleton x)
+            | otherwise = (B x b a, B x b b)
+          where (a, b) = copy2 (half (n-1))
+
+inBounds i xs = (i >= 0) && inb xs i
+  where inb E _ = False
+        inb (B _ a b) i
+          | odd i     = inb a (half i)
+          | i == 0    = True
+          | otherwise = inb b (half i - 1)
+
+lookup i xs = runFail_ (lookupM i xs)
+
+lookupM i xs
+  | i < 0     = fail "BraunSeq.lookupM: bad subscript"
+  | otherwise = look xs i
+  where look E _ = nothing
+        look (B x a b) i
+          | odd i     = look a (half i)
+          | i == 0    = return x
+          | otherwise = look b (half i - 1)
+        nothing = fail "BraunSeq.lookupM: not found"
+
+lookupWithDefault d i xs = if i < 0 then d
+                           else look xs i
+  where look E _ = d
+        look (B x a b) i
+          | odd i     = look a (half i)
+          | i == 0    = x
+          | otherwise = look b (half i - 1)
+
+update i y xs = if i < 0 then xs else upd i xs
+  where upd _ E = E
+        upd i (B x a b)
+          | odd i     = B x (upd (half i) a) b
+          | i == 0    = B y a b
+          | otherwise = B x a (upd (half i - 1) b)
+
+adjust f i xs = if i < 0 then xs else adj i xs
+  where adj _ E = E
+        adj i (B x a b)
+          | odd i     = B x (adj (half i) a) b
+          | i == 0    = B (f x) a b
+          | otherwise = B x a (adj (half i - 1) b)
+
+mapWithIndex f xs = mwi 0 1 xs
+  where mwi _ _ E = E
+        mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b)
+          where dd = d+d
+
+take n xs = if n <= 0 then E else ta n xs
+  where ta _ E = E
+        ta n (B x a b)
+            | odd n     = B x (ta m a) (ta m b)
+            | n == 0    = E
+            | otherwise = B x (ta m a) (ta (m-1) b)
+          where m = half n
+
+drop n xs = if n <= 0 then xs else dr n xs
+  where dr _ E = E
+        dr n t@(B _ a b)
+            | odd n     = combine (dr m a) (dr m b)
+            | n == 0    = t
+            | otherwise = combine (dr (m-1) b) (dr m a)
+          where m = half n
+
+zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d)
+zip _ _ = E
+
+zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f)
+zip3 _ _ _ = E
+
+zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d)
+zipWith _ _ _ = E
+
+zipWith3 fn (B x a b) (B y c d) (B z e f) =
+    B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f)
+zipWith3 _ _ _ _ = E
+
+unzip E = (E, E)
+unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2)
+  where (a1,a2) = unzip a
+        (b1,b2) = unzip b
+
+unzip3 E = (E, E, E)
+unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3)
+  where (a1,a2,a3) = unzip3 a
+        (b1,b2,b3) = unzip3 b
+
+unzipWith _ _ E = (E, E)
+unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2)
+  where (a1,a2) = unzipWith f g a
+        (b1,b2) = unzipWith f g b
+
+unzipWith3 _ _ _ E = (E, E, E)
+unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3)
+  where (a1,a2,a3) = unzipWith3 f g h a
+        (b1,b2,b3) = unzipWith3 f g h b
+
+
+strict s@E = s
+strict s@(B _ l r) = strict l `seq` strict r `seq` s
+
+strictWith _ s@E = s
+strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s
+
+-- invariants:
+--   * Left subtree is exactily the same size as the right
+--     subtree, or one element larger
+
+-- structuralInvariant :: Seq a -> Bool
+structuralInvariant E         = True
+structuralInvariant (B _ l r) = isJust (check l r)
+
+  where check :: Seq a -> Seq a -> Maybe Int
+        check E           E           = Just 1
+        check (B _ E E)   E           = Just 2
+        check (B _ l1 l2) (B _ r1 r2) = do
+           x <- check l1 l2
+           y <- check r1 r2
+           if (x == y) || (x == y + 1)
+              then return (x+y+1)
+              else fail "unbalanced tree"
+        check _ _ = fail "unbalanced tree"
+
+
+-- the remaining functions all use defaults
+
+concat = concatUsingFoldr
+reverseOnto = reverseOntoUsingReverse
+concatMap = concatMapUsingFoldr
+fold = foldrUsingLists
+fold' f = foldl'UsingLists (flip f)
+fold1 = fold1UsingFold
+fold1' = fold1'UsingFold'
+foldr = foldrUsingLists
+foldr' = foldr'UsingLists
+foldl = foldlUsingLists
+foldl' = foldl'UsingLists
+foldr1 = foldr1UsingLists
+foldr1' = foldr1'UsingLists
+foldl1 = foldl1UsingLists
+foldl1' = foldl1UsingLists
+reducer = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+reduce1 = reduce1UsingLists
+reduce1' = reduce1'UsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+splitAt = splitAtDefault
+subseq = subseqDefault
+filter = filterUsingLists
+partition = partitionUsingLists
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+-- instance Eq (Seq a) is derived
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = arbitrary >>= (return . fromList)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary xs = coarbitrary (toList xs)
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/Defaults.hs view

@@ -1,514 +1,516 @@--- |---   Module      :  Data.Edison.Seq.Defaults---   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  internal (unstable)---   Portability :  GHC, Hugs (MPTC and FD)------   This module provides default implementations of many of---   the sequence operations.  It is used to fill in implementations---   and is not intended for end users.--module Data.Edison.Seq.Defaults where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Char (isSpace)--import Data.Edison.Prelude ( runFail_ )-import Data.Edison.Seq-import qualified Data.Edison.Seq.ListSeq as L--rconsUsingAppend :: Sequence s => a -> s a -> s a-rconsUsingAppend x s = append s (singleton x)--rconsUsingFoldr :: Sequence s => a -> s a -> s a-rconsUsingFoldr x s = foldr lcons (singleton x) s--appendUsingFoldr :: Sequence s => s a -> s a -> s a-appendUsingFoldr s t | null t = s-                            | otherwise = foldr lcons t s--rviewDefault :: (Fail.MonadFail m, Sequence s) => s a -> m (a, s a)-rviewDefault xs-  | null xs   = fail $ instanceName xs ++ ".rview: empty sequence"-  | otherwise = return (rhead xs, rtail xs)---rtailUsingLview :: (Sequence s) => s a -> s a-rtailUsingLview xs =-    case lview xs of-      Nothing      -> error $ instanceName xs ++ ".rtail: empty sequence"-      Just (x, xs) -> rt x xs-  where rt x xs =-          case lview xs of-            Nothing      -> empty-            Just (y, ys) -> lcons x (rt y ys)--rtailMUsingLview :: (Fail.MonadFail m, Sequence s) => s a -> m (s a)-rtailMUsingLview xs =-    case lview xs of-      Nothing      -> fail $ instanceName xs ++ ".rtailM: empty sequence"-      Just (x, xs) -> return (rt x xs)-  where rt x xs =-          case lview xs of-            Nothing      -> empty-            Just (y, ys) -> lcons x (rt y ys)----concatUsingFoldr :: Sequence s => s (s a) -> s a-concatUsingFoldr = foldr append empty--reverseUsingReverseOnto :: Sequence s => s a -> s a-reverseUsingReverseOnto s = reverseOnto s empty--reverseUsingLists :: Sequence s => s a -> s a-reverseUsingLists = fromList . L.reverse . toList--reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a-reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs--reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a-reverseOntoUsingReverse = append . reverse--fromListUsingCons :: Sequence s => [a] -> s a-fromListUsingCons = L.foldr lcons empty--toListUsingFoldr :: Sequence s => s a -> [a]-toListUsingFoldr = foldr (:) []--mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b-mapUsingFoldr f = foldr (lcons . f) empty--concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b-concatMapUsingFoldr f = foldr (append . f) empty--foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b-foldrUsingLists f e xs = L.foldr f e (toList xs)--foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b-foldr'UsingLists f e xs = L.foldr' f e (toList xs)--foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b-foldlUsingLists f e xs = L.foldl f e (toList xs)--foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b-foldl'UsingLists f e xs = L.foldl' f e (toList xs)--foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldr1UsingLists f xs = L.foldr1 f (toList xs)--foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldr1'UsingLists f xs = L.foldr1' f (toList xs)--foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldl1UsingLists f xs = L.foldl1 f (toList xs)--foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldl1'UsingLists f xs = L.foldl1' f (toList xs)--fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a-fold1UsingFold f xs =-    case lview xs of-      Nothing      -> error $ instanceName xs ++ ".fold1: empty sequence"-      Just (x, xs) -> fold f x xs--fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a-fold1'UsingFold' f xs =-    case lview xs of-      Nothing      -> error $ instanceName xs ++ ".fold1': empty sequence"-      Just (x, xs) -> fold' f x xs--foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a-foldr1UsingLview f xs =-    case lview xs of-      Nothing      -> error $ instanceName xs ++ ".foldr1: empty sequence"-      Just (x, xs) -> fr1 x xs-  where fr1 x xs =-          case lview xs of-            Nothing     -> x-            Just (y,ys) -> f x (fr1 y ys)--foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a-foldr1'UsingLview f xs =-     case lview xs of-        Nothing     -> error $ instanceName xs ++ ".foldr1': empty sequence"-        Just (x,xs) -> fr1 x xs-  where fr1 x xs =-          case lview xs of-             Nothing     -> x-             Just (y,ys) -> f x $! (fr1 y ys)--foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a-foldl1UsingFoldl f xs =-    case lview xs of-      Nothing     -> error $ instanceName xs ++ ".foldl1: empty sequence"-      Just (x,xs) -> foldl f x xs--foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a-foldl1'UsingFoldl' f xs =-    case lview xs of-      Nothing     -> error $ instanceName xs ++ ".foldl1': empty sequence"-      Just (x,xs) -> foldl' f x xs--reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducerUsingReduce1 f e s-  | null s = e-  | otherwise = f (reduce1 f s) e--reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducer'UsingReduce1' f e s-  | null s = e-  | otherwise = f (reduce1' f s) e--reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducelUsingReduce1 f e s-  | null s = e-  | otherwise = f e (reduce1 f s)--reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducel'UsingReduce1' f e s-  | null s = e-  | otherwise = f e (reduce1' f s)--reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-reduce1UsingLists f s = L.reduce1 f (toList s)--reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-reduce1'UsingLists f s = L.reduce1' f (toList s)--copyUsingLists :: Sequence s => Int -> a -> s a-copyUsingLists n x = fromList (L.copy n x)---inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool-inBoundsUsingDrop i s =-  i >= 0 && not (null (drop i s))--inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool-inBoundsUsingLookupM i s =-  case lookupM i s of-    Just _  -> True-    Nothing -> False--inBoundsUsingSize :: Sequence s => Int -> s a -> Bool-inBoundsUsingSize i s = i >= 0 && i < size s--lookupUsingLookupM :: Sequence s => Int -> s a -> a-lookupUsingLookupM i s = runFail_ (lookupM i s)--lookupUsingDrop :: Sequence s => Int -> s a -> a-lookupUsingDrop i s-  | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript"-  | otherwise = lhead s'-  where s' = drop i s--lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a-lookupWithDefaultUsingLookupM d i s =-  case lookupM i s of-    Nothing -> d-    Just x  -> x--lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a-lookupWithDefaultUsingDrop d i s-  | i < 0 || null s' = d-  | otherwise = lhead s'-  where s' = drop i s--lookupMUsingDrop :: (Fail.MonadFail m, Sequence s) => Int -> s a -> m a-lookupMUsingDrop i s-  -- XXX better error message!-  | i < 0 || null s' = fail $ instanceName s-                        ++ ".lookupMUsingDrop: empty sequence"-  | otherwise        = return (lhead s')-  where s' = drop i s--filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingLview p xs =-  case lview xs of-    Nothing     -> empty-    Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs--filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingLists p xs =-  fromList (L.filter p (toList xs))--filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingFoldr p = foldr pcons empty-  where pcons x xs = if p x then lcons x xs else xs--partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-partitionUsingLists p xs =-  let (ys,zs) = L.partition p (toList xs)-  in (fromList ys, fromList zs)--partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-partitionUsingFoldr p = foldr pcons (empty, empty)-  where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs')--updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a-updateUsingAdjust i y = adjust (const y) i--updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a-updateUsingSplitAt i x xs-  | i < 0 = xs-  | otherwise = let (ys,zs) = splitAt i xs-                in if null zs then xs else append ys (lcons x (ltail zs))--adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a-adjustUsingLists f i xs = fromList (L.adjust f i (toList xs))--adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a-adjustUsingSplitAt f i xs-  | i < 0 = xs-  | otherwise = let (ys,zs) = splitAt i xs-                in case lview zs of-                     Nothing      -> xs-                     Just (z,zs') -> append ys (lcons (f z) zs')--{--insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a-insertAtUsingLists i x xs =-  fromList (L.insertAt i x (toList xs))--insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a-insertAtUsingSplitAt i x xs-  | (xs_before, xs_after) <- splitAt i xs =-      append xs_before (lcons x xs_after)--deleteAtUsingLists :: Sequence s => Int -> s a -> s a-deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs))--deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a-deleteAtUsingSplitAt i xs-  | (xs_before, xs_after) <- splitAt i xs =-      append xs_before (ltail xs_after)--}--mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b-mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs))--foldrWithIndexUsingLists ::-  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b-foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs)--foldrWithIndex'UsingLists ::-  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b-foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs)--foldlWithIndexUsingLists ::-  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b-foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs)--foldlWithIndex'UsingLists ::-  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b-foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs)--takeUsingLists :: Sequence s => Int -> s a -> s a-takeUsingLists i s = fromList (L.take i (toList s))--takeUsingLview :: Sequence s => Int -> s a -> s a-takeUsingLview i xs-  | i <= 0 = empty-  | otherwise = case lview xs of-                  Nothing -> empty-                  Just (x,xs') -> lcons x (take (i-1) xs')--dropUsingLists :: Sequence s => Int -> s a -> s a-dropUsingLists i s = fromList (L.drop i (toList s))--dropUsingLtail :: Sequence s => Int -> s a -> s a-dropUsingLtail i xs-  | i <= 0 || null xs = xs-  | otherwise = dropUsingLtail (i-1) (ltail xs)--splitAtDefault :: Sequence s => Int -> s a -> (s a, s a)-splitAtDefault i s = (take i s, drop i s)--splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a)-splitAtUsingLview i xs-  | i <= 0 = (empty,xs)-  | otherwise = case lview xs of-                  Nothing      -> (empty,empty)-                  Just (x,xs') -> (lcons x ys,zs)-                    where (ys,zs) = splitAtUsingLview (i-1) xs'--subseqDefault :: Sequence s => Int -> Int -> s a -> s a-subseqDefault i len xs = take len (drop i xs)--takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-takeWhileUsingLview p xs =-  case lview xs of-    Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs')-    _                  -> empty--dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-dropWhileUsingLview p xs =-  case lview xs of-    Just (x,xs') | p x -> dropWhileUsingLview p xs'-    _                  -> xs--splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-splitWhileUsingLview p xs =-  case lview xs of-    Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs'-                          in (lcons x front, back)-    _                  -> (empty, xs)--zipUsingLview :: Sequence s => s a -> s b -> s (a,b)-zipUsingLview xs ys =-  case lview xs of-    Nothing -> empty-    Just (x,xs') ->-      case lview ys of-        Nothing -> empty-        Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys')--zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c)-zip3UsingLview xs ys zs =-  case lview xs of-    Nothing -> empty-    Just (x,xs') ->-      case lview ys of-        Nothing -> empty-        Just (y,ys') ->-          case lview zs of-            Nothing -> empty-            Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs')--zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c-zipWithUsingLview f xs ys =-  case lview xs of-    Nothing -> empty-    Just (x,xs') ->-      case lview ys of-        Nothing -> empty-        Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys')--zipWith3UsingLview ::-  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d-zipWith3UsingLview f xs ys zs =-  case lview xs of-    Nothing -> empty-    Just (x,xs') ->-      case lview ys of-        Nothing -> empty-        Just (y,ys') ->-          case lview zs of-            Nothing -> empty-            Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs')--zipUsingLists :: Sequence s => s a -> s b -> s (a,b)-zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys))--zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c)-zip3UsingLists xs ys zs =-  fromList (L.zip3 (toList xs) (toList ys) (toList zs))--zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c-zipWithUsingLists f xs ys =-  fromList (L.zipWith f (toList xs) (toList ys))--zipWith3UsingLists ::-  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d-zipWith3UsingLists f xs ys zs =-  fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs))--unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b)-unzipUsingLists xys =-  case L.unzip (toList xys) of-    (xs, ys) -> (fromList xs, fromList ys)--unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b)-unzipUsingFoldr = foldr pcons (empty,empty)-  where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys)--unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c)-unzip3UsingLists xyzs =-  case L.unzip3 (toList xyzs) of-    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)--unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c)-unzip3UsingFoldr = foldr tcons (empty,empty,empty)-  where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs)--unzipWithUsingLists ::-  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)-unzipWithUsingLists f g xys =-  case L.unzipWith f g (toList xys) of-    (xs, ys) -> (fromList xs, fromList ys)--unzipWithUsingFoldr ::-  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)-unzipWithUsingFoldr f g = foldr pcons (empty,empty)-  where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys)--unzipWith3UsingLists ::-  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)-unzipWith3UsingLists f g h xyzs =-  case L.unzipWith3 f g h (toList xyzs) of-    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)--unzipWith3UsingFoldr ::-  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)-unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty)-  where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs)--showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS-showsPrecUsingToList i xs rest-   | i == 0    = concat [    instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest-   | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest)--readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a)-readsPrecUsingFromList _ xs =-   let result = maybeParens p xs-       p xs = tokenMatch ((instanceName x)++".fromList") xs-                >>= readsPrec 10-                >>= \(l,rest) -> return (fromList l,rest)--       -- play games with the typechecker so we don't have to use-       -- extensions for scoped type variables-       ~[(x,_)] = result--   in result--defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering-defaultCompare a b =-   case (lview a, lview b) of-     (Nothing, Nothing) -> EQ-     (Nothing, _      ) -> LT-     (_      , Nothing) -> GT-     (Just (x,xs), Just (y,ys)) ->-        case compare x y of-           EQ -> defaultCompare xs ys-           c -> c---dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a]-dropMatch [] ys = return ys-dropMatch (x:xs) (y:ys)-    | x == y    = dropMatch xs ys-    | otherwise = mzero-dropMatch _ _   = mzero--tokenMatch :: MonadPlus m => String -> String -> m String-tokenMatch token str = dropMatch token (munch str) >>= return . munch-   where munch = dropWhile isSpace--readSParens :: ReadS a -> ReadS a-readSParens p xs = return xs-     >>= tokenMatch "("-     >>= p-     >>= \(x,xs') -> return xs'-     >>= tokenMatch ")"-     >>= \rest -> return (x,rest)--maybeParens :: ReadS a -> ReadS a-maybeParens p xs = readSParens p xs `mplus` p xs+-- |
+--   Module      :  Data.Edison.Seq.Defaults
+--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  internal (unstable)
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module provides default implementations of many of
+--   the sequence operations.  It is used to fill in implementations
+--   and is not intended for end users.
+
+module Data.Edison.Seq.Defaults where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Char (isSpace)
+
+import Data.Edison.Prelude ( runFail_ )
+import Data.Edison.Seq
+import qualified Data.Edison.Seq.ListSeq as L
+
+rconsUsingAppend :: Sequence s => a -> s a -> s a
+rconsUsingAppend x s = append s (singleton x)
+
+rconsUsingFoldr :: Sequence s => a -> s a -> s a
+rconsUsingFoldr x s = foldr lcons (singleton x) s
+
+appendUsingFoldr :: Sequence s => s a -> s a -> s a
+appendUsingFoldr s t | null t = s
+                            | otherwise = foldr lcons t s
+
+rviewDefault :: (Fail.MonadFail m, Sequence s) => s a -> m (a, s a)
+rviewDefault xs
+  | null xs   = fail $ instanceName xs ++ ".rview: empty sequence"
+  | otherwise = return (rhead xs, rtail xs)
+
+
+rtailUsingLview :: (Sequence s) => s a -> s a
+rtailUsingLview xs =
+    case lview xs of
+      Nothing      -> error $ instanceName xs ++ ".rtail: empty sequence"
+      Just (x, xs) -> rt x xs
+  where rt x xs =
+          case lview xs of
+            Nothing      -> empty
+            Just (y, ys) -> lcons x (rt y ys)
+
+rtailMUsingLview :: (Fail.MonadFail m, Sequence s) => s a -> m (s a)
+rtailMUsingLview xs =
+    case lview xs of
+      Nothing      -> fail $ instanceName xs ++ ".rtailM: empty sequence"
+      Just (x, xs) -> return (rt x xs)
+  where rt x xs =
+          case lview xs of
+            Nothing      -> empty
+            Just (y, ys) -> lcons x (rt y ys)
+
+
+
+concatUsingFoldr :: Sequence s => s (s a) -> s a
+concatUsingFoldr = foldr append empty
+
+reverseUsingReverseOnto :: Sequence s => s a -> s a
+reverseUsingReverseOnto s = reverseOnto s empty
+
+reverseUsingLists :: Sequence s => s a -> s a
+reverseUsingLists = fromList . L.reverse . toList
+
+reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a
+reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs
+
+reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a
+reverseOntoUsingReverse = append . reverse
+
+fromListUsingCons :: Sequence s => [a] -> s a
+fromListUsingCons = L.foldr lcons empty
+
+toListUsingFoldr :: Sequence s => s a -> [a]
+toListUsingFoldr = foldr (:) []
+
+mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b
+mapUsingFoldr f = foldr (lcons . f) empty
+
+concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b
+concatMapUsingFoldr f = foldr (append . f) empty
+
+foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b
+foldrUsingLists f e xs = L.foldr f e (toList xs)
+
+foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b
+foldr'UsingLists f e xs = L.foldr' f e (toList xs)
+
+foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b
+foldlUsingLists f e xs = L.foldl f e (toList xs)
+
+foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b
+foldl'UsingLists f e xs = L.foldl' f e (toList xs)
+
+foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+foldr1UsingLists f xs = L.foldr1 f (toList xs)
+
+foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+foldr1'UsingLists f xs = L.foldr1' f (toList xs)
+
+foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+foldl1UsingLists f xs = L.foldl1 f (toList xs)
+
+foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+foldl1'UsingLists f xs = L.foldl1' f (toList xs)
+
+fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a
+fold1UsingFold f xs =
+    case lview xs of
+      Nothing      -> error $ instanceName xs ++ ".fold1: empty sequence"
+      Just (x, xs) -> fold f x xs
+
+fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a
+fold1'UsingFold' f xs =
+    case lview xs of
+      Nothing      -> error $ instanceName xs ++ ".fold1': empty sequence"
+      Just (x, xs) -> fold' f x xs
+
+foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a
+foldr1UsingLview f xs =
+    case lview xs of
+      Nothing      -> error $ instanceName xs ++ ".foldr1: empty sequence"
+      Just (x, xs) -> fr1 x xs
+  where fr1 x xs =
+          case lview xs of
+            Nothing     -> x
+            Just (y,ys) -> f x (fr1 y ys)
+
+foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a
+foldr1'UsingLview f xs =
+     case lview xs of
+        Nothing     -> error $ instanceName xs ++ ".foldr1': empty sequence"
+        Just (x,xs) -> fr1 x xs
+  where fr1 x xs =
+          case lview xs of
+             Nothing     -> x
+             Just (y,ys) -> f x $! (fr1 y ys)
+
+foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a
+foldl1UsingFoldl f xs =
+    case lview xs of
+      Nothing     -> error $ instanceName xs ++ ".foldl1: empty sequence"
+      Just (x,xs) -> foldl f x xs
+
+foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a
+foldl1'UsingFoldl' f xs =
+    case lview xs of
+      Nothing     -> error $ instanceName xs ++ ".foldl1': empty sequence"
+      Just (x,xs) -> foldl' f x xs
+
+reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a
+reducerUsingReduce1 f e s
+  | null s = e
+  | otherwise = f (reduce1 f s) e
+
+reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a
+reducer'UsingReduce1' f e s
+  | null s = e
+  | otherwise = f (reduce1' f s) e
+
+reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a
+reducelUsingReduce1 f e s
+  | null s = e
+  | otherwise = f e (reduce1 f s)
+
+reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a
+reducel'UsingReduce1' f e s
+  | null s = e
+  | otherwise = f e (reduce1' f s)
+
+reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+reduce1UsingLists f s = L.reduce1 f (toList s)
+
+reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a
+reduce1'UsingLists f s = L.reduce1' f (toList s)
+
+copyUsingLists :: Sequence s => Int -> a -> s a
+copyUsingLists n x = fromList (L.copy n x)
+
+
+inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool
+inBoundsUsingDrop i s =
+  i >= 0 && not (null (drop i s))
+
+inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool
+inBoundsUsingLookupM i s =
+  case lookupM i s of
+    Just _  -> True
+    Nothing -> False
+
+inBoundsUsingSize :: Sequence s => Int -> s a -> Bool
+inBoundsUsingSize i s = i >= 0 && i < size s
+
+lookupUsingLookupM :: Sequence s => Int -> s a -> a
+lookupUsingLookupM i s = runFail_ (lookupM i s)
+
+lookupUsingDrop :: Sequence s => Int -> s a -> a
+lookupUsingDrop i s
+  | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript"
+  | otherwise = lhead s'
+  where s' = drop i s
+
+lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a
+lookupWithDefaultUsingLookupM d i s =
+  case lookupM i s of
+    Nothing -> d
+    Just x  -> x
+
+lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a
+lookupWithDefaultUsingDrop d i s
+  | i < 0 || null s' = d
+  | otherwise = lhead s'
+  where s' = drop i s
+
+lookupMUsingDrop :: (Fail.MonadFail m, Sequence s) => Int -> s a -> m a
+lookupMUsingDrop i s
+  -- XXX better error message!
+  | i < 0 || null s' = fail $ instanceName s
+                        ++ ".lookupMUsingDrop: empty sequence"
+  | otherwise        = return (lhead s')
+  where s' = drop i s
+
+filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a
+filterUsingLview p xs =
+  case lview xs of
+    Nothing     -> empty
+    Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs
+
+filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a
+filterUsingLists p xs =
+  fromList (L.filter p (toList xs))
+
+filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a
+filterUsingFoldr p = foldr pcons empty
+  where pcons x xs = if p x then lcons x xs else xs
+
+partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a)
+partitionUsingLists p xs =
+  let (ys,zs) = L.partition p (toList xs)
+  in (fromList ys, fromList zs)
+
+partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a)
+partitionUsingFoldr p = foldr pcons (empty, empty)
+  where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs')
+
+updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a
+updateUsingAdjust i y = adjust (const y) i
+
+updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a
+updateUsingSplitAt i x xs
+  | i < 0 = xs
+  | otherwise = let (ys,zs) = splitAt i xs
+                in if null zs then xs else append ys (lcons x (ltail zs))
+
+adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a
+adjustUsingLists f i xs = fromList (L.adjust f i (toList xs))
+
+adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a
+adjustUsingSplitAt f i xs
+  | i < 0 = xs
+  | otherwise = let (ys,zs) = splitAt i xs
+                in case lview zs of
+                     Nothing      -> xs
+                     Just (z,zs') -> append ys (lcons (f z) zs')
+
+{-
+insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a
+insertAtUsingLists i x xs =
+  fromList (L.insertAt i x (toList xs))
+
+insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a
+insertAtUsingSplitAt i x xs
+  | (xs_before, xs_after) <- splitAt i xs =
+      append xs_before (lcons x xs_after)
+
+deleteAtUsingLists :: Sequence s => Int -> s a -> s a
+deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs))
+
+deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a
+deleteAtUsingSplitAt i xs
+  | (xs_before, xs_after) <- splitAt i xs =
+      append xs_before (ltail xs_after)
+-}
+
+mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b
+mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs))
+
+foldrWithIndexUsingLists ::
+  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b
+foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs)
+
+foldrWithIndex'UsingLists ::
+  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b
+foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs)
+
+foldlWithIndexUsingLists ::
+  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b
+foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs)
+
+foldlWithIndex'UsingLists ::
+  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b
+foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs)
+
+takeUsingLists :: Sequence s => Int -> s a -> s a
+takeUsingLists i s = fromList (L.take i (toList s))
+
+takeUsingLview :: Sequence s => Int -> s a -> s a
+takeUsingLview i xs
+  | i <= 0 = empty
+  | otherwise = case lview xs of
+                  Nothing -> empty
+                  Just (x,xs') -> lcons x (take (i-1) xs')
+
+dropUsingLists :: Sequence s => Int -> s a -> s a
+dropUsingLists i s = fromList (L.drop i (toList s))
+
+dropUsingLtail :: Sequence s => Int -> s a -> s a
+dropUsingLtail i xs
+  | i <= 0 || null xs = xs
+  | otherwise = dropUsingLtail (i-1) (ltail xs)
+
+splitAtDefault :: Sequence s => Int -> s a -> (s a, s a)
+splitAtDefault i s = (take i s, drop i s)
+
+splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a)
+splitAtUsingLview i xs
+  | i <= 0 = (empty,xs)
+  | otherwise = case lview xs of
+                  Nothing      -> (empty,empty)
+                  Just (x,xs') -> (lcons x ys,zs)
+                    where (ys,zs) = splitAtUsingLview (i-1) xs'
+
+subseqDefault :: Sequence s => Int -> Int -> s a -> s a
+subseqDefault i len xs = take len (drop i xs)
+
+takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a
+takeWhileUsingLview p xs =
+  case lview xs of
+    Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs')
+    _                  -> empty
+
+dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a
+dropWhileUsingLview p xs =
+  case lview xs of
+    Just (x,xs') | p x -> dropWhileUsingLview p xs'
+    _                  -> xs
+
+splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a)
+splitWhileUsingLview p xs =
+  case lview xs of
+    Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs'
+                          in (lcons x front, back)
+    _                  -> (empty, xs)
+
+zipUsingLview :: Sequence s => s a -> s b -> s (a,b)
+zipUsingLview xs ys =
+  case lview xs of
+    Nothing -> empty
+    Just (x,xs') ->
+      case lview ys of
+        Nothing -> empty
+        Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys')
+
+zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c)
+zip3UsingLview xs ys zs =
+  case lview xs of
+    Nothing -> empty
+    Just (x,xs') ->
+      case lview ys of
+        Nothing -> empty
+        Just (y,ys') ->
+          case lview zs of
+            Nothing -> empty
+            Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs')
+
+zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c
+zipWithUsingLview f xs ys =
+  case lview xs of
+    Nothing -> empty
+    Just (x,xs') ->
+      case lview ys of
+        Nothing -> empty
+        Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys')
+
+zipWith3UsingLview ::
+  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d
+zipWith3UsingLview f xs ys zs =
+  case lview xs of
+    Nothing -> empty
+    Just (x,xs') ->
+      case lview ys of
+        Nothing -> empty
+        Just (y,ys') ->
+          case lview zs of
+            Nothing -> empty
+            Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs')
+
+zipUsingLists :: Sequence s => s a -> s b -> s (a,b)
+zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys))
+
+zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c)
+zip3UsingLists xs ys zs =
+  fromList (L.zip3 (toList xs) (toList ys) (toList zs))
+
+zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c
+zipWithUsingLists f xs ys =
+  fromList (L.zipWith f (toList xs) (toList ys))
+
+zipWith3UsingLists ::
+  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d
+zipWith3UsingLists f xs ys zs =
+  fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs))
+
+unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b)
+unzipUsingLists xys =
+  case L.unzip (toList xys) of
+    (xs, ys) -> (fromList xs, fromList ys)
+
+unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b)
+unzipUsingFoldr = foldr pcons (empty,empty)
+  where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys)
+
+unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c)
+unzip3UsingLists xyzs =
+  case L.unzip3 (toList xyzs) of
+    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)
+
+unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c)
+unzip3UsingFoldr = foldr tcons (empty,empty,empty)
+  where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs)
+
+unzipWithUsingLists ::
+  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)
+unzipWithUsingLists f g xys =
+  case L.unzipWith f g (toList xys) of
+    (xs, ys) -> (fromList xs, fromList ys)
+
+unzipWithUsingFoldr ::
+  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)
+unzipWithUsingFoldr f g = foldr pcons (empty,empty)
+  where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys)
+
+unzipWith3UsingLists ::
+  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)
+unzipWith3UsingLists f g h xyzs =
+  case L.unzipWith3 f g h (toList xyzs) of
+    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)
+
+unzipWith3UsingFoldr ::
+  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)
+unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty)
+  where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs)
+
+showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS
+showsPrecUsingToList i xs rest
+   | i == 0    = concat [    instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest
+   | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest)
+
+readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a)
+readsPrecUsingFromList _ xs =
+   let result = maybeParens p xs
+       p xs = tokenMatch ((instanceName x)++".fromList") xs
+                >>= readsPrec 10
+                >>= \(l,rest) -> return (fromList l,rest)
+
+       -- play games with the typechecker so we don't have to use
+       -- extensions for scoped type variables
+       x = case result of
+        [(x',_)] -> x'
+        _ -> undefined
+
+   in result
+
+defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering
+defaultCompare a b =
+   case (lview a, lview b) of
+     (Nothing, Nothing) -> EQ
+     (Nothing, _      ) -> LT
+     (_      , Nothing) -> GT
+     (Just (x,xs), Just (y,ys)) ->
+        case compare x y of
+           EQ -> defaultCompare xs ys
+           c -> c
+
+
+dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a]
+dropMatch [] ys = return ys
+dropMatch (x:xs) (y:ys)
+    | x == y    = dropMatch xs ys
+    | otherwise = mzero
+dropMatch _ _   = mzero
+
+tokenMatch :: MonadPlus m => String -> String -> m String
+tokenMatch token str = dropMatch token (munch str) >>= return . munch
+   where munch = dropWhile isSpace
+
+readSParens :: ReadS a -> ReadS a
+readSParens p xs = return xs
+     >>= tokenMatch "("
+     >>= p
+     >>= \(x,xs') -> return xs'
+     >>= tokenMatch ")"
+     >>= \rest -> return (x,rest)
+
+maybeParens :: ReadS a -> ReadS a
+maybeParens p xs = readSParens p xs `mplus` p xs

src/Data/Edison/Seq/FingerSeq.hs view

@@ -1,402 +1,402 @@--- |---   Module      :  Data.Edison.Seq.FingerSeq---   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)---module Data.Edison.Seq.FingerSeq (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldlWithIndex,-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import qualified Prelude-import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App-import Data.Edison.Prelude (measure, Measured(), runFail_)-import qualified Data.Edison.Seq as S-import Data.Edison.Seq.Defaults-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck--#ifdef __GLASGOW_HASKELL__-import GHC.Exts (unsafeCoerce#)-#endif---import qualified Data.Edison.Concrete.FingerTree as FT--moduleName     :: String-moduleName = "Data.Edison.Seq.FingerSeq"---newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show)--unSizeM :: SizeM -> Int-unSizeM (SizeM x) = x--instance Semigroup SizeM where-   (<>) = (+)-instance Monoid SizeM where-   mempty  = 0-   mappend = (SG.<>)--newtype Elem a = Elem a--unElem :: Elem t -> t-unElem (Elem x) = x--instance Measured SizeM (Elem a) where-   measure _ = 1--newtype Seq a = Seq (FT.FingerTree SizeM (Elem a))--unSeq :: Seq t -> FT.FingerTree SizeM (Elem t)-unSeq (Seq ft) = ft----empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--#ifdef __GLASGOW_HASKELL__--mapElem, mapUnElem :: t -> b-mapElem   = unsafeCoerce#-mapUnElem = unsafeCoerce#--#else--mapElem   = Prelude.map Elem-mapUnElem = Prelude.map unElem--#endif--null         = FT.null . unSeq-empty        = Seq FT.empty-singleton    = Seq . FT.singleton . Elem-lcons x      = Seq . FT.lcons (Elem x) . unSeq-rcons x      = Seq . FT.rcons (Elem x) . unSeq-append p q   = Seq $ FT.append (unSeq p) (unSeq q)-fromList     = Seq . FT.fromList . mapElem-toList       = mapUnElem . FT.toList . unSeq-reverse      = Seq . FT.reverse . unSeq-size         = unSizeM . measure . unSeq-strict       = Seq . FT.strict . unSeq-strictWith f = Seq . FT.strictWith (f . unElem) . unSeq-structuralInvariant = FT.structuralInvariant . unSeq--#ifdef __GLASGOW_HASKELL__--lview (Seq xs) =-  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)-  in  f (FT.lview xs)--rview (Seq xs) =-  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)-  in  f (FT.rview xs)--#else--lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs)-rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs)--#endif---lheadM xs = lview xs >>= return . fst-ltailM xs = lview xs >>= return . snd-rheadM xs = rview xs >>= return . fst-rtailM xs = rview xs >>= return . snd-lhead = runFail_ . lheadM-ltail = runFail_ . ltailM-rhead = runFail_ . rheadM-rtail = runFail_ . rtailM--fold     = foldr-fold'    = foldr'-fold1    = foldr1-fold1'   = foldr1'--#ifdef __GLASGOW_HASKELL__--foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)-foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)--reduce1  f (Seq xs) = unElem $ FT.reduce1  (unsafeCoerce# f) xs-reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs--map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs--#else--foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)-foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)--reduce1  f (Seq xs) = unElem $ FT.reduce1  ( \(Elem x) (Elem y) -> Elem $ f x y) xs-reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs--map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs--#endif--lookupM i (Seq xs)-    | inBounds i (Seq xs) =-        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of-           FT.Split _ (Elem x) _ -> return x--    | otherwise = fail "FingerSeq.lookupM: index out of bounds"--lookupWithDefault d i (Seq xs)-    | inBounds i (Seq xs) =-        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of-           FT.Split _ (Elem x) _ -> x--    | otherwise = d--update i x (Seq xs)-    | inBounds i (Seq xs) =-        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of-           FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r--    | otherwise = Seq xs--adjust f i (Seq xs)-    | inBounds i (Seq xs) =-        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of-           FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r--    | otherwise = Seq xs--take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs-drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs-splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b)---inBounds = inBoundsUsingSize-lookup   = lookupUsingLookupM--foldr1 f xs =-   case rview xs of-      Nothing      -> error "FingerSeq.foldr1: empty sequence"-      Just (x,xs') -> foldr f x xs'--foldr1' f xs =-   case rview xs of-      Nothing      -> error "FingerSeq.foldr1': empty sequence"-      Just (x,xs') -> foldr' f x xs'--foldl    = foldlUsingLists-foldl'   = foldl'UsingLists-foldl1   = foldl1UsingLists-foldl1'  = foldl1'UsingLists--reducer  = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel  = reducelUsingReduce1-reducel' = reducel'UsingReduce1'--copy        = copyUsingLists-concat      = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-concatMap   = concatMapUsingFoldr-subseq      = subseqDefault-filter      = filterUsingLview-partition   = partitionUsingFoldr-takeWhile   = takeWhileUsingLview-dropWhile   = dropWhileUsingLview-splitWhile  = splitWhileUsingLview--mapWithIndex    = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists--zip = zipUsingLview-zip3 = zip3UsingLview-zipWith = zipWithUsingLview-zipWith3 = zipWith3UsingLview--unzip = unzipUsingFoldr-unzip3 = unzip3UsingFoldr-unzipWith = unzipWithUsingFoldr-unzipWith3 = unzipWith3UsingFoldr---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;-   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Eq a => Eq (Seq a) where-  xs == ys = toList xs == toList ys--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Elem a) where-   arbitrary   = arbitrary >>= return . Elem--instance CoArbitrary a => CoArbitrary (Elem a) where-   coarbitrary = coarbitrary . unElem--instance Arbitrary a => Arbitrary (Seq a) where-   arbitrary   = arbitrary >>= return . Seq--instance CoArbitrary a => CoArbitrary (Seq a) where-   coarbitrary = coarbitrary . unSeq--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.FingerSeq
+--   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+
+
+module Data.Edison.Seq.FingerSeq (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldlWithIndex,
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import qualified Prelude
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+import Data.Edison.Prelude (measure, Measured(), runFail_)
+import qualified Data.Edison.Seq as S
+import Data.Edison.Seq.Defaults
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (unsafeCoerce#)
+#endif
+
+
+import qualified Data.Edison.Concrete.FingerTree as FT
+
+moduleName     :: String
+moduleName = "Data.Edison.Seq.FingerSeq"
+
+
+newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show)
+
+unSizeM :: SizeM -> Int
+unSizeM (SizeM x) = x
+
+instance Semigroup SizeM where
+   (<>) = (+)
+instance Monoid SizeM where
+   mempty  = 0
+   mappend = (SG.<>)
+
+newtype Elem a = Elem a
+
+unElem :: Elem t -> t
+unElem (Elem x) = x
+
+instance Measured SizeM (Elem a) where
+   measure _ = 1
+
+newtype Seq a = Seq (FT.FingerTree SizeM (Elem a))
+
+unSeq :: Seq t -> FT.FingerTree SizeM (Elem t)
+unSeq (Seq ft) = ft
+
+
+
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+#ifdef __GLASGOW_HASKELL__
+
+mapElem, mapUnElem :: t -> b
+mapElem   = unsafeCoerce#
+mapUnElem = unsafeCoerce#
+
+#else
+
+mapElem   = Prelude.map Elem
+mapUnElem = Prelude.map unElem
+
+#endif
+
+null         = FT.null . unSeq
+empty        = Seq FT.empty
+singleton    = Seq . FT.singleton . Elem
+lcons x      = Seq . FT.lcons (Elem x) . unSeq
+rcons x      = Seq . FT.rcons (Elem x) . unSeq
+append p q   = Seq $ FT.append (unSeq p) (unSeq q)
+fromList     = Seq . FT.fromList . mapElem
+toList       = mapUnElem . FT.toList . unSeq
+reverse      = Seq . FT.reverse . unSeq
+size         = unSizeM . measure . unSeq
+strict       = Seq . FT.strict . unSeq
+strictWith f = Seq . FT.strictWith (f . unElem) . unSeq
+structuralInvariant = FT.structuralInvariant . unSeq
+
+#ifdef __GLASGOW_HASKELL__
+
+lview (Seq xs) =
+  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)
+  in  f (FT.lview xs)
+
+rview (Seq xs) =
+  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)
+  in  f (FT.rview xs)
+
+#else
+
+lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs)
+rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs)
+
+#endif
+
+
+lheadM xs = lview xs >>= return . fst
+ltailM xs = lview xs >>= return . snd
+rheadM xs = rview xs >>= return . fst
+rtailM xs = rview xs >>= return . snd
+lhead = runFail_ . lheadM
+ltail = runFail_ . ltailM
+rhead = runFail_ . rheadM
+rtail = runFail_ . rtailM
+
+fold     = foldr
+fold'    = foldr'
+fold1    = foldr1
+fold1'   = foldr1'
+
+#ifdef __GLASGOW_HASKELL__
+
+foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)
+foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)
+
+reduce1  f (Seq xs) = unElem $ FT.reduce1  (unsafeCoerce# f) xs
+reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs
+
+map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs
+
+#else
+
+foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)
+foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)
+
+reduce1  f (Seq xs) = unElem $ FT.reduce1  ( \(Elem x) (Elem y) -> Elem $ f x y) xs
+reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs
+
+map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs
+
+#endif
+
+lookupM i (Seq xs)
+    | inBounds i (Seq xs) =
+        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
+           FT.Split _ (Elem x) _ -> return x
+
+    | otherwise = fail "FingerSeq.lookupM: index out of bounds"
+
+lookupWithDefault d i (Seq xs)
+    | inBounds i (Seq xs) =
+        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
+           FT.Split _ (Elem x) _ -> x
+
+    | otherwise = d
+
+update i x (Seq xs)
+    | inBounds i (Seq xs) =
+        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
+           FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r
+
+    | otherwise = Seq xs
+
+adjust f i (Seq xs)
+    | inBounds i (Seq xs) =
+        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
+           FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r
+
+    | otherwise = Seq xs
+
+take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs
+drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs
+splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b)
+
+
+inBounds = inBoundsUsingSize
+lookup   = lookupUsingLookupM
+
+foldr1 f xs =
+   case rview xs of
+      Nothing      -> error "FingerSeq.foldr1: empty sequence"
+      Just (x,xs') -> foldr f x xs'
+
+foldr1' f xs =
+   case rview xs of
+      Nothing      -> error "FingerSeq.foldr1': empty sequence"
+      Just (x,xs') -> foldr' f x xs'
+
+foldl    = foldlUsingLists
+foldl'   = foldl'UsingLists
+foldl1   = foldl1UsingLists
+foldl1'  = foldl1'UsingLists
+
+reducer  = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel  = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+
+copy        = copyUsingLists
+concat      = concatUsingFoldr
+reverseOnto = reverseOntoUsingReverse
+concatMap   = concatMapUsingFoldr
+subseq      = subseqDefault
+filter      = filterUsingLview
+partition   = partitionUsingFoldr
+takeWhile   = takeWhileUsingLview
+dropWhile   = dropWhileUsingLview
+splitWhile  = splitWhileUsingLview
+
+mapWithIndex    = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+
+zip = zipUsingLview
+zip3 = zip3UsingLview
+zipWith = zipWithUsingLview
+zipWith3 = zipWith3UsingLview
+
+unzip = unzipUsingFoldr
+unzip3 = unzip3UsingFoldr
+unzipWith = unzipWithUsingFoldr
+unzipWith3 = unzipWith3UsingFoldr
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;
+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Eq a => Eq (Seq a) where
+  xs == ys = toList xs == toList ys
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Elem a) where
+   arbitrary   = arbitrary >>= return . Elem
+
+instance CoArbitrary a => CoArbitrary (Elem a) where
+   coarbitrary = coarbitrary . unElem
+
+instance Arbitrary a => Arbitrary (Seq a) where
+   arbitrary   = arbitrary >>= return . Seq
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+   coarbitrary = coarbitrary . unSeq
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/JoinList.hs view

@@ -1,443 +1,443 @@--- |---   Module      :  Data.Edison.Seq.JoinList---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Join lists. All running times are as listed in "Data.Edison.Seq" except---   for the following:------   * rcons, append         @O( 1 )@------   * ltail*, lview         @O( 1 )@    when used single-threaded, @O( n )@ otherwise------   * lhead*                @O( n )@------   * inBounds, lookup      @O( n )@------   * copy                  @O( log i )@------   * concat                @O( n1 )@------   * concatMap, (>>=)      @O( n * t )@, where @n@ is the length of the input sequence and---                                         @t@ is the running time of @f@--module Data.Edison.Seq.JoinList (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldlWithIndex,-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S ( Sequence(..) )-import qualified Control.Applicative as App--import Data.Edison.Seq.Defaults-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.JoinList"--data Seq a = E | L a | A (Seq a) (Seq a)-  -- invariant: E never a child of A--half :: Int -> Int-half n = n `div` 2--empty = E-singleton = L--lcons x E = L x-lcons x xs = A (L x) xs--rcons x E = L x-rcons x xs = A xs (L x)--append E ys = ys-append xs E = xs-append xs ys = A xs ys----- path reversal on lview/ltail--lview E = fail "JoinList.lview: empty sequence"-lview (L x) = return (x, E)-lview (A xs ys) = lvw xs ys-  where lvw E _ = error "JoinList.lvw: bug"-        lvw (L x) zs = return (x, zs)-        lvw (A xs ys) zs = lvw xs (A ys zs)--lhead E = error "JoinList.lhead: empty sequence"-lhead (L x) = x-lhead (A xs _) = lhead xs--lheadM E = fail "JoinList.lheadM: empty sequence"-lheadM (L x) = return x-lheadM (A xs _) = lheadM xs--ltail E = error "JoinList.ltail: empty sequence"-ltail (L _) = E-ltail (A xs ys) = ltl xs ys-  where ltl E _ = error "JoinList.ltl: bug"-        ltl (L _) zs = zs-        ltl (A xs ys) zs = ltl xs (A ys zs)--ltailM E = fail "JoinList.ltailM: empty sequence"-ltailM (L _) = return E-ltailM (A xs ys) = return (ltl xs ys)-  where ltl E _ = error "JoinList.ltl: bug"-        ltl (L _) zs = zs-        ltl (A xs ys) zs = ltl xs (A ys zs)----- Don't want to do plain path reversal on rview/rtail because of expectation--- that left accesses are more common, so we would prefer to keep the left--- spine short.--rview E = fail "JoinLis.rview: empty sequence"-rview (L x) = return (x, E)-rview (A xs ys) = rvw xs ys-  where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s-        rvw xs (A ys (L x)) = return (x, A xs ys)-        rvw xs (L x) = return (x, xs)-        rvw _ _ = error "JoinList.rvw: bug"--rhead E = error "JoinList.rhead: empty sequence"-rhead (L x) = x-rhead (A _ ys) = rhead ys--rheadM E = fail "JoinList.rheadM: empty sequence"-rheadM (L x) = return x-rheadM (A _ ys) = rheadM ys--rtail E = error "JoinList.rtail: empty sequence"-rtail (L _) = E-rtail (A xs ys) = rtl xs ys-  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)-        rtl xs (A ys (L _)) = A xs ys-        rtl xs (L _) = xs-        rtl _ _ = error "JoinList.rtl: bug"--rtailM E = fail "JoinList.rtailM: empty sequence"-rtailM (L _) = return E-rtailM (A xs ys) = return (rtl xs ys)-  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)-        rtl xs (A ys (L _)) = A xs ys-        rtl xs (L _) = xs-        rtl _ _ = error "JoinList.rtl: bug"--null E = True-null _ = False--size xs = sz xs (0::Int)-  where sz E n = n-        sz (L _) n = n + (1::Int)-        sz (A xs ys) n = sz xs (sz ys n)--reverse (A xs ys) = A (reverse ys) (reverse xs)-reverse xs = xs -- L x or E--toList xs = tol xs []-  where tol E rest = rest-        tol (L x) rest = x:rest-        tol (A xs ys) rest = tol xs (tol ys rest)--map _ E = E-map f (L x) = L (f x)-map f (A xs ys) = A (map f xs) (map f ys)--fold   = foldr-fold'  = foldr'-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (L x) = f x e-foldr f e (A xs ys) = foldr f (foldr f e ys) xs-foldr' _ e E = e-foldr' f e (L x) = f x $! e-foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs--foldl _ e E = e-foldl f e (L x) = f e x-foldl f e (A xs ys) = foldl f (foldl f e xs) ys--foldl' _ e E = e-foldl' f e (L x) = e `seq` f e x-foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys--foldr1 _ E = error "JoinList.foldr1: empty sequence"-foldr1 _ (L x) = x-foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs--foldr1' _ E = error "JoinLis.foldr1': empty sequence"-foldr1' _ (L x) = x-foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs--foldl1 _ E = error "JoinList.foldl1: empty sequence"-foldl1 _ (L x) = x-foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys--foldl1' _ E = error "JoinList.foldl1': empty sequence"-foldl1' _ (L x) = x-foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys--copy n x-    | n <= 0 = E-    | otherwise = cpy n x-  where cpy n x  -- n > 0-          | even n = let xs = cpy (half n) x-                     in A xs xs-          | n == 1 = L x-          | otherwise = let xs = cpy (half n) x-                        in A (L x) (A xs xs)---strict s@E = s-strict s@(L _) = s-strict s@(A l r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(L x) = f x `seq` s-strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s---- invariants:---   * 'E' is never a child of 'A'--structuralInvariant E = True-structuralInvariant s = check s-  where check E = False-        check (L _) = True-        check (A s1 s2) = check s1 && check s2---concat = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-fromList = fromListUsingCons-concatMap = concatMapUsingFoldr--reducer  = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel  = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1  = reduce1UsingLists-reduce1' = reduce1'UsingLists--inBounds = inBoundsUsingDrop-lookup = lookupUsingDrop-lookupM = lookupMUsingDrop-lookupWithDefault = lookupWithDefaultUsingDrop--update = updateUsingSplitAt-adjust = adjustUsingSplitAt--mapWithIndex = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists--take = takeUsingLview-drop = dropUsingLtail-splitAt = splitAtUsingLview-subseq = subseqDefault--filter = filterUsingLview-partition = partitionUsingFoldr-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview--zip = zipUsingLview-zip3 = zip3UsingLview-zipWith = zipWithUsingLview-zipWith3 = zipWith3UsingLview--unzip = unzipUsingFoldr-unzip3 = unzip3UsingFoldr-unzipWith = unzipWithUsingFoldr-unzipWith3 = unzipWith3UsingFoldr---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;-   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Eq a => Eq (Seq a) where-  xs == ys = toList xs == toList ys--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = sized arbTree-    where arbTree 0 = return E-          arbTree 1 = liftM L arbitrary-          arbTree n =-            frequency [(1, liftM L arbitrary),-                       (4, liftM2 A (arbTree (n `div` 2))-                                    (arbTree (n `div` 2)))]--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary E = variant 0-  coarbitrary (L x) = variant 1 . coarbitrary x-  coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.JoinList
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Join lists. All running times are as listed in "Data.Edison.Seq" except
+--   for the following:
+--
+--   * rcons, append         @O( 1 )@
+--
+--   * ltail*, lview         @O( 1 )@    when used single-threaded, @O( n )@ otherwise
+--
+--   * lhead*                @O( n )@
+--
+--   * inBounds, lookup      @O( n )@
+--
+--   * copy                  @O( log i )@
+--
+--   * concat                @O( n1 )@
+--
+--   * concatMap, (>>=)      @O( n * t )@, where @n@ is the length of the input sequence and
+--                                         @t@ is the running time of @f@
+
+module Data.Edison.Seq.JoinList (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldlWithIndex,
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import qualified Control.Applicative as App
+
+import Data.Edison.Seq.Defaults
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.JoinList"
+
+data Seq a = E | L a | A (Seq a) (Seq a)
+  -- invariant: E never a child of A
+
+half :: Int -> Int
+half n = n `div` 2
+
+empty = E
+singleton = L
+
+lcons x E = L x
+lcons x xs = A (L x) xs
+
+rcons x E = L x
+rcons x xs = A xs (L x)
+
+append E ys = ys
+append xs E = xs
+append xs ys = A xs ys
+
+
+-- path reversal on lview/ltail
+
+lview E = fail "JoinList.lview: empty sequence"
+lview (L x) = return (x, E)
+lview (A xs ys) = lvw xs ys
+  where lvw E _ = error "JoinList.lvw: bug"
+        lvw (L x) zs = return (x, zs)
+        lvw (A xs ys) zs = lvw xs (A ys zs)
+
+lhead E = error "JoinList.lhead: empty sequence"
+lhead (L x) = x
+lhead (A xs _) = lhead xs
+
+lheadM E = fail "JoinList.lheadM: empty sequence"
+lheadM (L x) = return x
+lheadM (A xs _) = lheadM xs
+
+ltail E = error "JoinList.ltail: empty sequence"
+ltail (L _) = E
+ltail (A xs ys) = ltl xs ys
+  where ltl E _ = error "JoinList.ltl: bug"
+        ltl (L _) zs = zs
+        ltl (A xs ys) zs = ltl xs (A ys zs)
+
+ltailM E = fail "JoinList.ltailM: empty sequence"
+ltailM (L _) = return E
+ltailM (A xs ys) = return (ltl xs ys)
+  where ltl E _ = error "JoinList.ltl: bug"
+        ltl (L _) zs = zs
+        ltl (A xs ys) zs = ltl xs (A ys zs)
+
+
+-- Don't want to do plain path reversal on rview/rtail because of expectation
+-- that left accesses are more common, so we would prefer to keep the left
+-- spine short.
+
+rview E = fail "JoinLis.rview: empty sequence"
+rview (L x) = return (x, E)
+rview (A xs ys) = rvw xs ys
+  where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s
+        rvw xs (A ys (L x)) = return (x, A xs ys)
+        rvw xs (L x) = return (x, xs)
+        rvw _ _ = error "JoinList.rvw: bug"
+
+rhead E = error "JoinList.rhead: empty sequence"
+rhead (L x) = x
+rhead (A _ ys) = rhead ys
+
+rheadM E = fail "JoinList.rheadM: empty sequence"
+rheadM (L x) = return x
+rheadM (A _ ys) = rheadM ys
+
+rtail E = error "JoinList.rtail: empty sequence"
+rtail (L _) = E
+rtail (A xs ys) = rtl xs ys
+  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)
+        rtl xs (A ys (L _)) = A xs ys
+        rtl xs (L _) = xs
+        rtl _ _ = error "JoinList.rtl: bug"
+
+rtailM E = fail "JoinList.rtailM: empty sequence"
+rtailM (L _) = return E
+rtailM (A xs ys) = return (rtl xs ys)
+  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)
+        rtl xs (A ys (L _)) = A xs ys
+        rtl xs (L _) = xs
+        rtl _ _ = error "JoinList.rtl: bug"
+
+null E = True
+null _ = False
+
+size xs = sz xs (0::Int)
+  where sz E n = n
+        sz (L _) n = n + (1::Int)
+        sz (A xs ys) n = sz xs (sz ys n)
+
+reverse (A xs ys) = A (reverse ys) (reverse xs)
+reverse xs = xs -- L x or E
+
+toList xs = tol xs []
+  where tol E rest = rest
+        tol (L x) rest = x:rest
+        tol (A xs ys) rest = tol xs (tol ys rest)
+
+map _ E = E
+map f (L x) = L (f x)
+map f (A xs ys) = A (map f xs) (map f ys)
+
+fold   = foldr
+fold'  = foldr'
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr _ e E = e
+foldr f e (L x) = f x e
+foldr f e (A xs ys) = foldr f (foldr f e ys) xs
+foldr' _ e E = e
+foldr' f e (L x) = f x $! e
+foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs
+
+foldl _ e E = e
+foldl f e (L x) = f e x
+foldl f e (A xs ys) = foldl f (foldl f e xs) ys
+
+foldl' _ e E = e
+foldl' f e (L x) = e `seq` f e x
+foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys
+
+foldr1 _ E = error "JoinList.foldr1: empty sequence"
+foldr1 _ (L x) = x
+foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs
+
+foldr1' _ E = error "JoinLis.foldr1': empty sequence"
+foldr1' _ (L x) = x
+foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs
+
+foldl1 _ E = error "JoinList.foldl1: empty sequence"
+foldl1 _ (L x) = x
+foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys
+
+foldl1' _ E = error "JoinList.foldl1': empty sequence"
+foldl1' _ (L x) = x
+foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys
+
+copy n x
+    | n <= 0 = E
+    | otherwise = cpy n x
+  where cpy n x  -- n > 0
+          | even n = let xs = cpy (half n) x
+                     in A xs xs
+          | n == 1 = L x
+          | otherwise = let xs = cpy (half n) x
+                        in A (L x) (A xs xs)
+
+
+strict s@E = s
+strict s@(L _) = s
+strict s@(A l r) = strict l `seq` strict r `seq` s
+
+strictWith _ s@E = s
+strictWith f s@(L x) = f x `seq` s
+strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s
+
+-- invariants:
+--   * 'E' is never a child of 'A'
+
+structuralInvariant E = True
+structuralInvariant s = check s
+  where check E = False
+        check (L _) = True
+        check (A s1 s2) = check s1 && check s2
+
+
+concat = concatUsingFoldr
+reverseOnto = reverseOntoUsingReverse
+fromList = fromListUsingCons
+concatMap = concatMapUsingFoldr
+
+reducer  = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel  = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+reduce1  = reduce1UsingLists
+reduce1' = reduce1'UsingLists
+
+inBounds = inBoundsUsingDrop
+lookup = lookupUsingDrop
+lookupM = lookupMUsingDrop
+lookupWithDefault = lookupWithDefaultUsingDrop
+
+update = updateUsingSplitAt
+adjust = adjustUsingSplitAt
+
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+
+take = takeUsingLview
+drop = dropUsingLtail
+splitAt = splitAtUsingLview
+subseq = subseqDefault
+
+filter = filterUsingLview
+partition = partitionUsingFoldr
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+
+zip = zipUsingLview
+zip3 = zip3UsingLview
+zipWith = zipWithUsingLview
+zipWith3 = zipWith3UsingLview
+
+unzip = unzipUsingFoldr
+unzip3 = unzip3UsingFoldr
+unzipWith = unzipWithUsingFoldr
+unzipWith3 = unzipWith3UsingFoldr
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;
+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Eq a => Eq (Seq a) where
+  xs == ys = toList xs == toList ys
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = sized arbTree
+    where arbTree 0 = return E
+          arbTree 1 = liftM L arbitrary
+          arbTree n =
+            frequency [(1, liftM L arbitrary),
+                       (4, liftM2 A (arbTree (n `div` 2))
+                                    (arbTree (n `div` 2)))]
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary E = variant (0 :: Int)
+  coarbitrary (L x) = variant (1 :: Int) . coarbitrary x
+  coarbitrary (A xs ys) = variant (2 :: Int) . coarbitrary xs . coarbitrary ys
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/MyersStack.hs view

@@ -1,453 +1,453 @@--- |---   Module      :  Data.Edison.Seq.MyersStack---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Meyers Stacks.  All operations are as listed in "Data.Edison.Seq" except---   the following:------ * lookup, inBounds, drop  @O( min(i, log n) )@------ * rhead*, size  @O( log n )@------ * subseq        @O( min (i, log n) + len )@------   /References:/------ * Eugene Myers. \"An applicative random-access stack\". /Information---   Processing Letters/, 17(5):241-248, December 1983.--module Data.Edison.Seq.MyersStack (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App-import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.MyersStack"---data Seq a = E | C !Int a (Seq a) (Seq a)-  -- what about strictness flags on tail and jump-tail?---- auxiliary function-jump :: Seq t -> Seq t-jump (C _ _ _ (C _ _ _ xs')) = xs'-jump _ = error "MyersStack.jump: bug!"--empty = E-singleton x = C 1 x E E--lcons x xs@(C i _  _  (C j _ _ xs'))-    | i == j = C (1 + i + j) x xs xs'-lcons x xs = C 1 x xs xs--lview E = fail "MyersStack.lview: empty sequence"-lview (C _ x xs _) = return (x, xs)--lhead E = error "MyersStack.lhead: empty sequence"-lhead (C _ x _ _) = x--lheadM E = fail "MyersStack.lheadM: empty sequence"-lheadM (C _ x _ _) = return x--ltail E = error "MyersStack.ltail: empty sequence"-ltail (C _ _ xs _) = xs--ltailM E = fail "MyersStack.ltailM: empty sequence"-ltailM (C _ _ xs _) = return xs--rview E = fail "MyersStack.rview: empty sequence"-rview xs = return (rhead xs, rtail xs)--rhead E = error "MyersStack.rhead: empty sequence"-rhead (C _ x xs xs') = rh x xs xs'-  where rh _ _ (C _ y ys ys') = rh y ys ys'-        rh _ (C _ y ys ys') E = rh y ys ys'-        rh x E E = x--rheadM E = fail "MyersStack.rheadM: empty sequence"-rheadM (C _ x xs xs') = return (rh x xs xs')-  where rh _ _ (C _ y ys ys') = rh y ys ys'-        rh _ (C _ y ys ys') E = rh y ys ys'-        rh x E E = x--rtail E = error "MyersStack.rtail: empty sequence"-rtail (C _ x xs _) = rt x xs-  where rt _ E = E-        rt y (C _ x xs _) = lcons y (rt x xs)--rtailM E = fail "MyersStack.rtailM: empty sequence"-rtailM (C _ x xs _) = return (rt x xs)-  where rt _ E = E-        rt y (C _ x xs _) = lcons y (rt x xs)--null E = True-null _ = False--size xs = go xs-  where go E = (0::Int)-        go (C j _ _ xs') = j + size xs'--reverseOnto E ys = ys-reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys)--map _ E = E-map f (C j x xs _')-    | j == 1    = C j (f x) ys ys-    | otherwise = C j (f x) ys (jump ys)-  where ys = map f xs--fold  = foldr-fold' f = foldl' (flip f)-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (C _ x xs _) = f x (foldr f e xs)--foldr' _ e E = e-foldr' f e (C _ x xs _) = f x $! (foldr' f e xs)--foldl _ e E = e-foldl f e (C _ x xs _) = foldl f (f e x) xs--foldl' _ e E = e-foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs--foldr1 _ E = error "MyersStack.foldr1: empty sequence"-foldr1 f (C _ x xs _) = fr x xs-  where fr y E = y-        fr y (C _ x xs _) = f y (fr x xs)--foldr1' _ E = error "MyersStack.foldr1': empty sequence"-foldr1' f (C _ x xs _) = fr x xs-  where fr y E = y-        fr y (C _ x xs _) = f y $! (fr x xs)--foldl1 _ E = error "MyersStack.foldl1: empty sequence"-foldl1 f (C _ x xs _) = foldl f x xs--foldl1' _ E = error "MyersStack.foldl1': empty sequence"-foldl1' f (C _ x xs _ ) = foldl' f x xs--inBounds i xs = inb xs i-  where inb E _ = False-        inb (C j _ _ xs') i-          | i < j     = (i >= 0)-          | otherwise = inb xs' (i - j)--lookup i xs = runFail_ (lookupM i xs)--lookupM i xs = look xs i-  where look E _ = fail "MyersStack.lookup: bad subscript"-        look (C j x xs xs') i-          | i >= j   = look xs' (i - j)-          | i > 0    = look xs  (i - 1)-          | i == 0   = return x-          | otherwise = nothing-        nothing = fail "MyersStack.lookup: not found"--lookupWithDefault d i xs = look xs i-  where look E _ = d-        look (C j x xs xs') i-          | i >= j   = look xs' (i - j)-          | i > 0    = look xs  (i - 1)-          | i == 0   = x-          | otherwise = d--update i y xs = upd i xs-  where upd _ E = E-        upd 0 (C j _ xs xs') = C j y xs xs'-        upd i (C j x xs _)-            | j == 1    = C j x ys ys-            | otherwise = C j x ys (jump ys)-          where ys = upd (i - 1) xs--adjust f i xs = adj i xs-  where adj _ E = E-        adj 0 (C j x xs xs') = C j (f x) xs xs'-        adj i (C j x xs _)-            | j == 1    = C j x ys ys-            | otherwise = C j x ys (jump ys)-          where ys = adj (i - (1::Int)) xs--drop n xs = drp n xs-  where drp n xs | n <= 0 = xs-        drp _ E = E-        drp n (C j _ xs xs')-          | n < j     = drp (n - 1) xs-          | otherwise = drp (n - j) xs'--unzip E = (E, E)-unzip (C j (x,y) ps _')-    | j == 1    = (C j x xs xs, C j y ys ys)-    | otherwise = (C j x xs (jump xs), C j y ys (jump ys))-  where (xs,ys) = unzip ps--unzip3 E = (E, E, E)-unzip3 (C j (x,y,z) ts _')-    | j == 1    = (C j x xs xs, C j y ys ys, C j z zs zs)-    | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs))-  where (xs,ys,zs) = unzip3 ts--unzipWith _ _ E = (E, E)-unzipWith f g (C j x xs _)-    | j == 1    = (C j (f x) as as, C j (g x) bs bs)-    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs))-  where (as,bs) = unzipWith f g xs--unzipWith3 _ _ _ E = (E, E, E)-unzipWith3 f g h (C j x xs _)-    | j == 1    = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs)-    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs),-                   C j (h x) cs (jump cs))-  where (as,bs,cs) = unzipWith3 f g h xs--strict s@E = s-strict s@(C _ _ xs _) = strict xs `seq` s--strictWith _ s@E = s-strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s---- the remaining functions all use defaults--rcons = rconsUsingFoldr-append = appendUsingFoldr-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-reducer  = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel  = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1  = reduce1UsingLists-reduce1' = reduce1'UsingLists-copy = copyUsingLists-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists---- FIXME what are the structural invariants?-structuralInvariant = const True---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel';  reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Eq a => Eq (Seq a) where-  xs == ys =-    (size xs == size ys) && (toList xs == toList ys)--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList---instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = do xs <- arbitrary-                 return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary xs = coarbitrary (toList xs)--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)-----------------{--questions:-  - any benefit to-      E | C1 x xs | CJ Int# x xs xs'--  - any benefit to length instead of delta?--  - any benefit to delta not counting x (i.e., base 0 instead of base 1)?--I don't believe any will do any better, except possibly the first--}+-- |
+--   Module      :  Data.Edison.Seq.MyersStack
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Meyers Stacks.  All operations are as listed in "Data.Edison.Seq" except
+--   the following:
+--
+-- * lookup, inBounds, drop  @O( min(i, log n) )@
+--
+-- * rhead*, size  @O( log n )@
+--
+-- * subseq        @O( min (i, log n) + len )@
+--
+--   /References:/
+--
+-- * Eugene Myers. \"An applicative random-access stack\". /Information
+--   Processing Letters/, 17(5):241-248, December 1983.
+
+module Data.Edison.Seq.MyersStack (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.MyersStack"
+
+
+data Seq a = E | C !Int a (Seq a) (Seq a)
+  -- what about strictness flags on tail and jump-tail?
+
+-- auxiliary function
+jump :: Seq t -> Seq t
+jump (C _ _ _ (C _ _ _ xs')) = xs'
+jump _ = error "MyersStack.jump: bug!"
+
+empty = E
+singleton x = C 1 x E E
+
+lcons x xs@(C i _  _  (C j _ _ xs'))
+    | i == j = C (1 + i + j) x xs xs'
+lcons x xs = C 1 x xs xs
+
+lview E = fail "MyersStack.lview: empty sequence"
+lview (C _ x xs _) = return (x, xs)
+
+lhead E = error "MyersStack.lhead: empty sequence"
+lhead (C _ x _ _) = x
+
+lheadM E = fail "MyersStack.lheadM: empty sequence"
+lheadM (C _ x _ _) = return x
+
+ltail E = error "MyersStack.ltail: empty sequence"
+ltail (C _ _ xs _) = xs
+
+ltailM E = fail "MyersStack.ltailM: empty sequence"
+ltailM (C _ _ xs _) = return xs
+
+rview E = fail "MyersStack.rview: empty sequence"
+rview xs = return (rhead xs, rtail xs)
+
+rhead E = error "MyersStack.rhead: empty sequence"
+rhead (C _ x xs xs') = rh x xs xs'
+  where rh _ _ (C _ y ys ys') = rh y ys ys'
+        rh _ (C _ y ys ys') E = rh y ys ys'
+        rh x E E = x
+
+rheadM E = fail "MyersStack.rheadM: empty sequence"
+rheadM (C _ x xs xs') = return (rh x xs xs')
+  where rh _ _ (C _ y ys ys') = rh y ys ys'
+        rh _ (C _ y ys ys') E = rh y ys ys'
+        rh x E E = x
+
+rtail E = error "MyersStack.rtail: empty sequence"
+rtail (C _ x xs _) = rt x xs
+  where rt _ E = E
+        rt y (C _ x xs _) = lcons y (rt x xs)
+
+rtailM E = fail "MyersStack.rtailM: empty sequence"
+rtailM (C _ x xs _) = return (rt x xs)
+  where rt _ E = E
+        rt y (C _ x xs _) = lcons y (rt x xs)
+
+null E = True
+null _ = False
+
+size xs = go xs
+  where go E = (0::Int)
+        go (C j _ _ xs') = j + size xs'
+
+reverseOnto E ys = ys
+reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys)
+
+map _ E = E
+map f (C j x xs _')
+    | j == 1    = C j (f x) ys ys
+    | otherwise = C j (f x) ys (jump ys)
+  where ys = map f xs
+
+fold  = foldr
+fold' f = foldl' (flip f)
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr _ e E = e
+foldr f e (C _ x xs _) = f x (foldr f e xs)
+
+foldr' _ e E = e
+foldr' f e (C _ x xs _) = f x $! (foldr' f e xs)
+
+foldl _ e E = e
+foldl f e (C _ x xs _) = foldl f (f e x) xs
+
+foldl' _ e E = e
+foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs
+
+foldr1 _ E = error "MyersStack.foldr1: empty sequence"
+foldr1 f (C _ x xs _) = fr x xs
+  where fr y E = y
+        fr y (C _ x xs _) = f y (fr x xs)
+
+foldr1' _ E = error "MyersStack.foldr1': empty sequence"
+foldr1' f (C _ x xs _) = fr x xs
+  where fr y E = y
+        fr y (C _ x xs _) = f y $! (fr x xs)
+
+foldl1 _ E = error "MyersStack.foldl1: empty sequence"
+foldl1 f (C _ x xs _) = foldl f x xs
+
+foldl1' _ E = error "MyersStack.foldl1': empty sequence"
+foldl1' f (C _ x xs _ ) = foldl' f x xs
+
+inBounds i xs = inb xs i
+  where inb E _ = False
+        inb (C j _ _ xs') i
+          | i < j     = (i >= 0)
+          | otherwise = inb xs' (i - j)
+
+lookup i xs = runFail_ (lookupM i xs)
+
+lookupM i xs = look xs i
+  where look E _ = fail "MyersStack.lookup: bad subscript"
+        look (C j x xs xs') i
+          | i >= j   = look xs' (i - j)
+          | i > 0    = look xs  (i - 1)
+          | i == 0   = return x
+          | otherwise = nothing
+        nothing = fail "MyersStack.lookup: not found"
+
+lookupWithDefault d i xs = look xs i
+  where look E _ = d
+        look (C j x xs xs') i
+          | i >= j   = look xs' (i - j)
+          | i > 0    = look xs  (i - 1)
+          | i == 0   = x
+          | otherwise = d
+
+update i y xs = upd i xs
+  where upd _ E = E
+        upd 0 (C j _ xs xs') = C j y xs xs'
+        upd i (C j x xs _)
+            | j == 1    = C j x ys ys
+            | otherwise = C j x ys (jump ys)
+          where ys = upd (i - 1) xs
+
+adjust f i xs = adj i xs
+  where adj _ E = E
+        adj 0 (C j x xs xs') = C j (f x) xs xs'
+        adj i (C j x xs _)
+            | j == 1    = C j x ys ys
+            | otherwise = C j x ys (jump ys)
+          where ys = adj (i - (1::Int)) xs
+
+drop n xs = drp n xs
+  where drp n xs | n <= 0 = xs
+        drp _ E = E
+        drp n (C j _ xs xs')
+          | n < j     = drp (n - 1) xs
+          | otherwise = drp (n - j) xs'
+
+unzip E = (E, E)
+unzip (C j (x,y) ps _')
+    | j == 1    = (C j x xs xs, C j y ys ys)
+    | otherwise = (C j x xs (jump xs), C j y ys (jump ys))
+  where (xs,ys) = unzip ps
+
+unzip3 E = (E, E, E)
+unzip3 (C j (x,y,z) ts _')
+    | j == 1    = (C j x xs xs, C j y ys ys, C j z zs zs)
+    | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs))
+  where (xs,ys,zs) = unzip3 ts
+
+unzipWith _ _ E = (E, E)
+unzipWith f g (C j x xs _)
+    | j == 1    = (C j (f x) as as, C j (g x) bs bs)
+    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs))
+  where (as,bs) = unzipWith f g xs
+
+unzipWith3 _ _ _ E = (E, E, E)
+unzipWith3 f g h (C j x xs _)
+    | j == 1    = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs)
+    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs),
+                   C j (h x) cs (jump cs))
+  where (as,bs,cs) = unzipWith3 f g h xs
+
+strict s@E = s
+strict s@(C _ _ xs _) = strict xs `seq` s
+
+strictWith _ s@E = s
+strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s
+
+-- the remaining functions all use defaults
+
+rcons = rconsUsingFoldr
+append = appendUsingFoldr
+concat = concatUsingFoldr
+reverse = reverseUsingReverseOnto
+fromList = fromListUsingCons
+toList = toListUsingFoldr
+concatMap = concatMapUsingFoldr
+reducer  = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel  = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+reduce1  = reduce1UsingLists
+reduce1' = reduce1'UsingLists
+copy = copyUsingLists
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+take = takeUsingLists
+splitAt = splitAtDefault
+filter = filterUsingFoldr
+partition = partitionUsingFoldr
+subseq = subseqDefault
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+
+-- for zips, could optimize by calculating which one is shorter and
+-- retaining its shape
+
+zip = zipUsingLists
+zip3 = zip3UsingLists
+zipWith = zipWithUsingLists
+zipWith3 = zipWith3UsingLists
+
+-- FIXME what are the structural invariants?
+structuralInvariant = const True
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel';  reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Eq a => Eq (Seq a) where
+  xs == ys =
+    (size xs == size ys) && (toList xs == toList ys)
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = do xs <- arbitrary
+                 return (fromList xs)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary xs = coarbitrary (toList xs)
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)
+
+-------------
+
+{-
+questions:
+  - any benefit to
+      E | C1 x xs | CJ Int# x xs xs'
+
+  - any benefit to length instead of delta?
+
+  - any benefit to delta not counting x (i.e., base 0 instead of base 1)?
+
+I don't believe any will do any better, except possibly the first
+-}

src/Data/Edison/Seq/RandList.hs view

@@ -1,500 +1,500 @@--- |---   Module      :  Data.Edison.Seq.RandList---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Random-Access Lists.  All operations are as listed in "Data.Edison.Seq"---   except the following:------   * rhead*, size  @O( log n )@------   * copy, inBounds    @O( log i )@------   * lookup*, update, adjust, drop @O( min( i, log n ) )@------   * subseq            @O( min( i, log n ) + len )@------   /References:/------   * Chris Okasaki. /Purely Functional Data Structures/. 1998.---     Section 9.3.1.------   * Chris Okasaki. \"Purely Functional Random Access Lists\".  FPCA'95,---     pages 86-95.--module Data.Edison.Seq.RandList (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App--import Data.Edison.Prelude ( runFail_ )-import qualified Data.Edison.Seq as S( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Control.Monad.Fail as Fail-import Control.Monad-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-moduleName = "Data.Edison.Seq.RandList"---data Tree a = L a | T a (Tree a) (Tree a)   deriving (Eq)-data Seq a = E | C !Int (Tree a) (Seq a)    deriving (Eq)--half :: Int -> Int-half n = n `quot` 2  -- use a shift?--empty = E-singleton x = C 1 (L x) E--lcons x (C i s (C j t xs'))-    | i == j = C (1 + i + j) (T x s t) xs'-lcons x xs = C 1 (L x) xs--copy n x = if n <= 0 then E else buildTrees (1::Int) (L x)-  where buildTrees j t-          | j > n     = takeTrees n (half j) (child t) E-          | otherwise = buildTrees (1 + j + j) (T x t t)--        takeTrees i j t xs-          | i >= j = takeTrees (i - j) j t (C j t xs)-          | i > 0  = takeTrees i (half j) (child t) xs-          | otherwise = xs--        child (T _ _ t) = t-        child _ = error "RandList.copy: bug!"--lview E = fail "RandList.lview: empty sequence"-lview (C _ (L x) xs) = return (x, xs)-lview (C i (T x s t) xs) = return (x, C j s (C j t xs))-  where j = half i--lhead E = error "RandList.lhead: empty sequence"-lhead (C _ (L x) _) = x-lhead (C _ (T x _ _) _) = x--lheadM E = fail "RandList.lheadM: empty sequence"-lheadM (C _ (L x) _) = return x-lheadM (C _ (T x _ _) _) = return x--ltail E = error "RandList.ltail: empty sequence"-ltail (C _ (L _) xs) = xs-ltail (C i (T _ s t) xs) = C j s (C j t xs)-  where j = half i--ltailM E = fail "RandList.ltailM: empty sequence"-ltailM (C _ (L _) xs) = return xs-ltailM (C i (T _ s t) xs) = return (C j s (C j t xs))-  where j = half i--rhead E = error "RandList.rhead: empty sequence"-rhead (C _ t E) = treeLast t-  where treeLast (L x) = x-        treeLast (T _ _ t) = treeLast t-rhead (C _ _ xs) = rhead xs--rheadM E = fail "RandList.rhead: empty sequence"-rheadM (C _ t E) = return(treeLast t)-  where treeLast (L x) = x-        treeLast (T _ _ t) = treeLast t-rheadM (C _ _ xs) = rheadM xs---null E = True-null _ = False--size xs = sz xs-  where sz E = (0::Int)-        sz (C j _ xs) = j + sz xs--reverseOnto E ys = ys-reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys)-  where revTree (L x) ys = lcons x ys-        revTree (T x s t) ys = revTree t (revTree s (lcons x ys))--map _ E = E-map f (C j t xs) = C j (mapTree f t) (map f xs)-  where mapTree f (L x) = L (f x)-        mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t)--fold  = foldr-fold' f = foldl' (flip f)-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (C _ t xs) = foldTree t (foldr f e xs)-  where foldTree (L x) e = f x e-        foldTree (T x s t) e = f x (foldTree s (foldTree t e))--foldr' _ e E = e-foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs)-  where foldTree (L x) e = f x $! e-        foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e))--foldl _ e E = e-foldl f e (C _ t xs) = foldl f (foldTree e t) xs-  where foldTree e (L x) = f e x-        foldTree e (T x s t) = foldTree (foldTree (f e x) s) t--foldl' _ e E = e-foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs-  where foldTree e (L x) = e `seq` f e x-        foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t--reduce1 f xs = case lview xs of-                 Nothing      -> error "RandList.reduce1: empty seq"-                 Just (x, xs) -> red1 x xs-  where red1 x E = x-        red1 x (C _ t xs) = red1 (redTree x t) xs--        redTree x (L y) = f x y-        redTree x (T y s t) = redTree (redTree (f x y) s) t--reduce1' f xs = case lview xs of-                  Nothing      -> error "RandList.reduce1': empty seq"-                  Just (x, xs) -> red1 x xs-  where red1 x E = x-        red1 x (C _ t xs) = (red1 $! (redTree x t)) xs--        redTree x (L y) = x `seq` y `seq` f x y-        redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t---inBounds i xs = inb xs i-  where inb E _ = False-        inb (C j _ xs) i-          | i < j     = (i >= 0)-          | otherwise = inb xs (i - j)--lookup i xs = runFail_ (lookupM i xs)--lookupM i xs = look xs i-  where look E _ = fail "RandList.lookup bad subscript"-        look (C j t xs) i-            | i < j     = lookTree j t i-            | otherwise = look xs (i - j)--        lookTree _ (L x) i-            | i == 0    = return x-            | otherwise = nothing-        lookTree j (T x s t) i-            | i > k  = lookTree k t (i - 1 - k)-            | i /= 0 = lookTree k s (i - 1)-            | otherwise = return x-          where k = half j-        nothing = fail "RandList.lookup: not found"--lookupWithDefault d i xs = look xs i-  where look E _ = d-        look (C j t xs) i-            | i < j     = lookTree j t i-            | otherwise = look xs (i - j)--        lookTree _ (L x) i-            | i == 0    = x-            | otherwise = d-        lookTree j (T x s t) i-            | i > k   = lookTree k t (i - 1 - k)-            | i /= 0  = lookTree k s (i - 1)-            | otherwise = x-          where k = half j--update i y xs = upd i xs-  where upd _ E = E-        upd i (C j t xs)-            | i < j     = C j (updTree i j t) xs-            | otherwise = C j t (upd (i - j) xs)--        updTree i _ t@(L _)-            | i == 0    = L y-            | otherwise = t-        updTree i j (T x s t)-            | i > k   = T x s (updTree (i - 1 - k) k t)-            | i /= 0  = T x (updTree (i - 1) k s) t-            | otherwise = T y s t-          where k = half j--adjust f i xs = adj i xs-  where adj _ E = E-        adj i (C j t xs)-            | i < j     = C j (adjTree i j t) xs-            | otherwise = C j t (adj (i - j) xs)--        adjTree i _ t@(L x)-            | i == 0    = L (f x)-            | otherwise = t-        adjTree i j (T x s t)-            | i > k  = T x s (adjTree (i - 1 - k) k t)-            | i /= 0 = T x (adjTree (i - 1) k s) t-            | otherwise = T (f x) s t-          where k = half j--drop n xs = if n < 0 then xs else drp n xs-  where drp _ E = E-        drp i (C j t xs)-            | i < j     = drpTree i j t xs-            | otherwise = drp (i - j) xs--        drpTree 0 j t xs = C j t xs-        drpTree _ _ (L _) _ = error "RandList.drop: bug.  Impossible case!"-        drpTree i j (T _ s t) xs-            | i > k     = drpTree (i - 1 - k) k t xs-            | otherwise = drpTree (i - 1) k s (C k t xs)-          where k = half j--strict s@E = s-strict s@(C _ t xs) = strictTree t `seq` strict xs `seq` s--strictTree :: Tree t -> Tree t-strictTree t@(L _) = t-strictTree t@(T _ l r) = strictTree l `seq` strictTree r `seq` t--strictWith _ s@E = s-strictWith f s@(C _ t xs) = strictWithTree f t `seq` strictWith f xs `seq` s--strictWithTree :: (t -> a) -> Tree t -> Tree t-strictWithTree f t@(L x) = f x `seq` t-strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t----- the remaining functions all use defaults--rcons = rconsUsingFoldr-append = appendUsingFoldr-rview = rviewDefault-rtail = rtailUsingLview-rtailM = rtailMUsingLview-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-foldr1  = foldr1UsingLview-foldr1' = foldr1'UsingLview-foldl1  = foldl1UsingFoldl-foldl1' = foldl1'UsingFoldl'-reducer  = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel  = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- invariants:---   * list of complete binary trees in non-decreasing---     order by size---   * first argument to 'C' is the number---     of nodes in the tree-structuralInvariant :: Seq t -> Bool-structuralInvariant E = True-structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s--   where checkTree 1 (L _) = True-         checkTree w (T _ l r) =-             let w' = (w - 1) `div` 2-             in w' > 0 && checkTree w' l && checkTree w' r-         checkTree _ _ = False--         checkSeq _ E = True-         checkSeq x (C y t s) =-             x <= y && checkTree y t && checkSeq y s----- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = do xs <- arbitrary-                 return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary xs = coarbitrary (toList xs)--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.RandList
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Random-Access Lists.  All operations are as listed in "Data.Edison.Seq"
+--   except the following:
+--
+--   * rhead*, size  @O( log n )@
+--
+--   * copy, inBounds    @O( log i )@
+--
+--   * lookup*, update, adjust, drop @O( min( i, log n ) )@
+--
+--   * subseq            @O( min( i, log n ) + len )@
+--
+--   /References:/
+--
+--   * Chris Okasaki. /Purely Functional Data Structures/. 1998.
+--     Section 9.3.1.
+--
+--   * Chris Okasaki. \"Purely Functional Random Access Lists\".  FPCA'95,
+--     pages 86-95.
+
+module Data.Edison.Seq.RandList (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+
+import Data.Edison.Prelude ( runFail_ )
+import qualified Data.Edison.Seq as S( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import qualified Control.Monad.Fail as Fail
+import Control.Monad
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+moduleName = "Data.Edison.Seq.RandList"
+
+
+data Tree a = L a | T a (Tree a) (Tree a)   deriving (Eq)
+data Seq a = E | C !Int (Tree a) (Seq a)    deriving (Eq)
+
+half :: Int -> Int
+half n = n `quot` 2  -- use a shift?
+
+empty = E
+singleton x = C 1 (L x) E
+
+lcons x (C i s (C j t xs'))
+    | i == j = C (1 + i + j) (T x s t) xs'
+lcons x xs = C 1 (L x) xs
+
+copy n x = if n <= 0 then E else buildTrees (1::Int) (L x)
+  where buildTrees j t
+          | j > n     = takeTrees n (half j) (child t) E
+          | otherwise = buildTrees (1 + j + j) (T x t t)
+
+        takeTrees i j t xs
+          | i >= j = takeTrees (i - j) j t (C j t xs)
+          | i > 0  = takeTrees i (half j) (child t) xs
+          | otherwise = xs
+
+        child (T _ _ t) = t
+        child _ = error "RandList.copy: bug!"
+
+lview E = fail "RandList.lview: empty sequence"
+lview (C _ (L x) xs) = return (x, xs)
+lview (C i (T x s t) xs) = return (x, C j s (C j t xs))
+  where j = half i
+
+lhead E = error "RandList.lhead: empty sequence"
+lhead (C _ (L x) _) = x
+lhead (C _ (T x _ _) _) = x
+
+lheadM E = fail "RandList.lheadM: empty sequence"
+lheadM (C _ (L x) _) = return x
+lheadM (C _ (T x _ _) _) = return x
+
+ltail E = error "RandList.ltail: empty sequence"
+ltail (C _ (L _) xs) = xs
+ltail (C i (T _ s t) xs) = C j s (C j t xs)
+  where j = half i
+
+ltailM E = fail "RandList.ltailM: empty sequence"
+ltailM (C _ (L _) xs) = return xs
+ltailM (C i (T _ s t) xs) = return (C j s (C j t xs))
+  where j = half i
+
+rhead E = error "RandList.rhead: empty sequence"
+rhead (C _ t E) = treeLast t
+  where treeLast (L x) = x
+        treeLast (T _ _ t) = treeLast t
+rhead (C _ _ xs) = rhead xs
+
+rheadM E = fail "RandList.rhead: empty sequence"
+rheadM (C _ t E) = return(treeLast t)
+  where treeLast (L x) = x
+        treeLast (T _ _ t) = treeLast t
+rheadM (C _ _ xs) = rheadM xs
+
+
+null E = True
+null _ = False
+
+size xs = sz xs
+  where sz E = (0::Int)
+        sz (C j _ xs) = j + sz xs
+
+reverseOnto E ys = ys
+reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys)
+  where revTree (L x) ys = lcons x ys
+        revTree (T x s t) ys = revTree t (revTree s (lcons x ys))
+
+map _ E = E
+map f (C j t xs) = C j (mapTree f t) (map f xs)
+  where mapTree f (L x) = L (f x)
+        mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t)
+
+fold  = foldr
+fold' f = foldl' (flip f)
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr _ e E = e
+foldr f e (C _ t xs) = foldTree t (foldr f e xs)
+  where foldTree (L x) e = f x e
+        foldTree (T x s t) e = f x (foldTree s (foldTree t e))
+
+foldr' _ e E = e
+foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs)
+  where foldTree (L x) e = f x $! e
+        foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e))
+
+foldl _ e E = e
+foldl f e (C _ t xs) = foldl f (foldTree e t) xs
+  where foldTree e (L x) = f e x
+        foldTree e (T x s t) = foldTree (foldTree (f e x) s) t
+
+foldl' _ e E = e
+foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs
+  where foldTree e (L x) = e `seq` f e x
+        foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t
+
+reduce1 f xs = case lview xs of
+                 Nothing      -> error "RandList.reduce1: empty seq"
+                 Just (x, xs) -> red1 x xs
+  where red1 x E = x
+        red1 x (C _ t xs) = red1 (redTree x t) xs
+
+        redTree x (L y) = f x y
+        redTree x (T y s t) = redTree (redTree (f x y) s) t
+
+reduce1' f xs = case lview xs of
+                  Nothing      -> error "RandList.reduce1': empty seq"
+                  Just (x, xs) -> red1 x xs
+  where red1 x E = x
+        red1 x (C _ t xs) = (red1 $! (redTree x t)) xs
+
+        redTree x (L y) = x `seq` y `seq` f x y
+        redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t
+
+
+inBounds i xs = inb xs i
+  where inb E _ = False
+        inb (C j _ xs) i
+          | i < j     = (i >= 0)
+          | otherwise = inb xs (i - j)
+
+lookup i xs = runFail_ (lookupM i xs)
+
+lookupM i xs = look xs i
+  where look E _ = fail "RandList.lookup bad subscript"
+        look (C j t xs) i
+            | i < j     = lookTree j t i
+            | otherwise = look xs (i - j)
+
+        lookTree _ (L x) i
+            | i == 0    = return x
+            | otherwise = nothing
+        lookTree j (T x s t) i
+            | i > k  = lookTree k t (i - 1 - k)
+            | i /= 0 = lookTree k s (i - 1)
+            | otherwise = return x
+          where k = half j
+        nothing = fail "RandList.lookup: not found"
+
+lookupWithDefault d i xs = look xs i
+  where look E _ = d
+        look (C j t xs) i
+            | i < j     = lookTree j t i
+            | otherwise = look xs (i - j)
+
+        lookTree _ (L x) i
+            | i == 0    = x
+            | otherwise = d
+        lookTree j (T x s t) i
+            | i > k   = lookTree k t (i - 1 - k)
+            | i /= 0  = lookTree k s (i - 1)
+            | otherwise = x
+          where k = half j
+
+update i y xs = upd i xs
+  where upd _ E = E
+        upd i (C j t xs)
+            | i < j     = C j (updTree i j t) xs
+            | otherwise = C j t (upd (i - j) xs)
+
+        updTree i _ t@(L _)
+            | i == 0    = L y
+            | otherwise = t
+        updTree i j (T x s t)
+            | i > k   = T x s (updTree (i - 1 - k) k t)
+            | i /= 0  = T x (updTree (i - 1) k s) t
+            | otherwise = T y s t
+          where k = half j
+
+adjust f i xs = adj i xs
+  where adj _ E = E
+        adj i (C j t xs)
+            | i < j     = C j (adjTree i j t) xs
+            | otherwise = C j t (adj (i - j) xs)
+
+        adjTree i _ t@(L x)
+            | i == 0    = L (f x)
+            | otherwise = t
+        adjTree i j (T x s t)
+            | i > k  = T x s (adjTree (i - 1 - k) k t)
+            | i /= 0 = T x (adjTree (i - 1) k s) t
+            | otherwise = T (f x) s t
+          where k = half j
+
+drop n xs = if n < 0 then xs else drp n xs
+  where drp _ E = E
+        drp i (C j t xs)
+            | i < j     = drpTree i j t xs
+            | otherwise = drp (i - j) xs
+
+        drpTree 0 j t xs = C j t xs
+        drpTree _ _ (L _) _ = error "RandList.drop: bug.  Impossible case!"
+        drpTree i j (T _ s t) xs
+            | i > k     = drpTree (i - 1 - k) k t xs
+            | otherwise = drpTree (i - 1) k s (C k t xs)
+          where k = half j
+
+strict s@E = s
+strict s@(C _ t xs) = strictTree t `seq` strict xs `seq` s
+
+strictTree :: Tree t -> Tree t
+strictTree t@(L _) = t
+strictTree t@(T _ l r) = strictTree l `seq` strictTree r `seq` t
+
+strictWith _ s@E = s
+strictWith f s@(C _ t xs) = strictWithTree f t `seq` strictWith f xs `seq` s
+
+strictWithTree :: (t -> a) -> Tree t -> Tree t
+strictWithTree f t@(L x) = f x `seq` t
+strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t
+
+
+-- the remaining functions all use defaults
+
+rcons = rconsUsingFoldr
+append = appendUsingFoldr
+rview = rviewDefault
+rtail = rtailUsingLview
+rtailM = rtailMUsingLview
+concat = concatUsingFoldr
+reverse = reverseUsingReverseOnto
+fromList = fromListUsingCons
+toList = toListUsingFoldr
+concatMap = concatMapUsingFoldr
+foldr1  = foldr1UsingLview
+foldr1' = foldr1'UsingLview
+foldl1  = foldl1UsingFoldl
+foldl1' = foldl1'UsingFoldl'
+reducer  = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel  = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+take = takeUsingLists
+splitAt = splitAtDefault
+filter = filterUsingFoldr
+partition = partitionUsingFoldr
+subseq = subseqDefault
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+
+-- for zips, could optimize by calculating which one is shorter and
+-- retaining its shape
+
+zip = zipUsingLists
+zip3 = zip3UsingLists
+zipWith = zipWithUsingLists
+zipWith3 = zipWith3UsingLists
+unzip = unzipUsingLists
+unzip3 = unzip3UsingLists
+unzipWith = unzipWithUsingLists
+unzipWith3 = unzipWith3UsingLists
+
+-- invariants:
+--   * list of complete binary trees in non-decreasing
+--     order by size
+--   * first argument to 'C' is the number
+--     of nodes in the tree
+structuralInvariant :: Seq t -> Bool
+structuralInvariant E = True
+structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s
+
+   where checkTree 1 (L _) = True
+         checkTree w (T _ l r) =
+             let w' = (w - 1) `div` 2
+             in w' > 0 && checkTree w' l && checkTree w' r
+         checkTree _ _ = False
+
+         checkSeq _ E = True
+         checkSeq x (C y t s) =
+             x <= y && checkTree y t && checkSeq y s
+
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = do xs <- arbitrary
+                 return (fromList xs)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary xs = coarbitrary (toList xs)
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/RevSeq.hs view

@@ -1,399 +1,399 @@--- |---   Module      :  Data.Edison.Seq.RevSeq---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   This module defines a sequence adaptor @Rev s@.---   If @s@ is a sequence type constructor, then @Rev s@---   is a sequence type constructor that is identical to @s@,---   except that it is kept in the opposite order.---   Also keeps explicit track of the size of the sequence,---   similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq".------   This module is most useful when s is a sequence type---   that offers fast access to the front but slow access---   to the rear, and your application needs the opposite---   (i.e., fast access to the rear but slow access to the---   front).------   All time complexities are determined by the underlying---   sequence, except that the complexities for accessing---   the left and right sides of the sequence are exchanged,---   and size becomes @O( 1 )@.--module Data.Edison.Seq.RevSeq (-    -- * Rev Sequence Type-    Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName,instanceName,--    -- * Other supported operations-    fromSeq,toSeq--) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults -- only used by concatMap-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Data.Monoid-import Data.Semigroup as SG-import Test.QuickCheck----- signatures for exported functions-moduleName     :: String-instanceName   :: S.Sequence s => Rev s a -> String-empty          :: S.Sequence s => Rev s a-singleton      :: S.Sequence s => a -> Rev s a-lcons          :: S.Sequence s => a -> Rev s a -> Rev s a-rcons          :: S.Sequence s => a -> Rev s a -> Rev s a-append         :: S.Sequence s => Rev s a -> Rev s a -> Rev s a-lview          :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a)-lhead          :: S.Sequence s => Rev s a -> a-lheadM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a-ltail          :: S.Sequence s => Rev s a -> Rev s a-ltailM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a)-rview          :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a)-rhead          :: S.Sequence s => Rev s a -> a-rheadM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a-rtail          :: S.Sequence s => Rev s a -> Rev s a-rtailM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a)-null           :: S.Sequence s => Rev s a -> Bool-size           :: S.Sequence s => Rev s a -> Int-concat         :: S.Sequence s => Rev s (Rev s a) -> Rev s a-reverse        :: S.Sequence s => Rev s a -> Rev s a-reverseOnto    :: S.Sequence s => Rev s a -> Rev s a -> Rev s a-fromList       :: S.Sequence s => [a] -> Rev s a-toList         :: S.Sequence s => Rev s a -> [a]-map            :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b-concatMap      :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b-fold           :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-fold'          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-fold1          :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-fold1'         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldr          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-foldl          :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b-foldr1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldl1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-reducer        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reducel        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reduce1        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b-foldr1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldl1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reduce1'       :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-copy           :: S.Sequence s => Int -> a -> Rev s a-inBounds       :: S.Sequence s => Int -> Rev s a -> Bool-lookup         :: S.Sequence s => Int -> Rev s a -> a-lookupM        :: (S.Sequence s, Fail.MonadFail m) => Int -> Rev s a -> m a-lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a-update         :: S.Sequence s => Int -> a -> Rev s a -> Rev s a-adjust         :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a-mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b-foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b-foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b-foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b-foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b-take           :: S.Sequence s => Int -> Rev s a -> Rev s a-drop           :: S.Sequence s => Int -> Rev s a -> Rev s a-splitAt        :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)-subseq         :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a-filter         :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-partition      :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)-takeWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-dropWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-splitWhile     :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)-zip            :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b)-zip3           :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c)-zipWith        :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c-zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d-unzip          :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b)-unzip3         :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c)-unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)-unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)-strict         :: S.Sequence s => Rev s a -> Rev s a-strictWith     :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a-structuralInvariant :: S.Sequence s => Rev s a -> Bool---- bonus functions, not in Sequence signature-fromSeq        :: S.Sequence s => s a -> Rev s a-toSeq          :: S.Sequence s => Rev s a -> s a---moduleName = "Data.Edison.Seq.RevSeq"-instanceName (N _ s) = "RevSeq(" ++ S.instanceName s ++ ")"--data Rev s a = N !Int (s a)-  -- The Int is the size minus one.  The "minus one" makes indexing-  -- calculations easier.--fromSeq xs = N (S.size xs - 1) xs-toSeq (N _ xs) = xs--empty = N (-1) S.empty-singleton x = N 0 (S.singleton x)-lcons x (N m xs) = N (m+1) (S.rcons x xs)-rcons x (N m xs) = N (m+1) (S.lcons x xs)-append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs)--lview (N m xs) = case S.rview xs of-                   Nothing     -> fail "RevSeq.lview: empty sequence"-                   Just (x,xs) -> return (x, N (m-1) xs)--lhead (N _ xs) = S.rhead xs--lheadM (N _ xs) = S.rheadM xs--ltail (N (-1) _) = error "RevSeq.ltail: empty sequence"-ltail (N m xs) = N (m-1) (S.rtail xs)--ltailM (N (-1) _) = fail "RevSeq.ltailM: empty sequence"-ltailM (N m xs) = return (N (m-1) (S.rtail xs))--rview (N m xs) = case S.lview xs of-                   Nothing     -> fail "RevSeq.rview: empty sequence"-                   Just (x,xs) -> return (x, N (m-1) xs)--rhead (N _ xs) = S.lhead xs--rheadM (N _ xs) = S.lheadM xs--rtail (N (-1) _) = error "RevSeq.rtail: empty sequence"-rtail (N m xs) = N (m-1) (S.ltail xs)--rtailM (N (-1) _) = fail "RevSeq.rtailM: empty sequence"-rtailM (N m xs) = return (N (m-1) (S.ltail xs))--null (N m _) = m == -1-size (N m _) = m+1-concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))-reverse (N m xs) = N m (S.reverse xs)-reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs))-fromList = fromSeq . S.fromList . L.reverse-toList (N _ xs) = S.foldl (flip (:)) [] xs-map f (N m xs) = N m (S.map f xs)--concatMap = concatMapUsingFoldr -- only function that uses a default--fold f e (N _ xs) = S.fold f e xs-fold' f e (N _ xs) = S.fold' f e xs-fold1 f (N _ xs) = S.fold1 f xs-fold1' f (N _ xs) = S.fold1' f xs-foldr f e (N _ xs) = S.foldl (flip f) e xs-foldr' f e (N _ xs) = S.foldl' (flip f) e xs-foldl f e (N _ xs) = S.foldr (flip f) e xs-foldl' f e (N _ xs) = S.foldr' (flip f) e xs-foldr1 f (N _ xs) = S.foldl1 (flip f) xs-foldr1' f (N _ xs) = S.foldl1' (flip f) xs-foldl1 f (N _ xs) = S.foldr1 (flip f) xs-foldl1' f (N _ xs) = S.foldr1' (flip f) xs-reducer f e (N _ xs) = S.reducel (flip f) e xs-reducer' f e (N _ xs) = S.reducel' (flip f) e xs-reducel f e (N _ xs) = S.reducer (flip f) e xs-reducel' f e (N _ xs) = S.reducer' (flip f) e xs-reduce1 f (N _ xs) = S.reduce1 (flip f) xs-reduce1' f (N _ xs) = S.reduce1' (flip f) xs--copy n x-    | n <= 0 = empty-    | otherwise = N (n-1) (S.copy n x)--inBounds i (N m _) = (i >= 0) && (i <= m)-lookup i (N m xs) = S.lookup (m-i) xs-lookupM i (N m xs) = S.lookupM (m-i) xs-lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs-update i x (N m xs) = N m (S.update (m-i) x xs)-adjust f i (N m xs) = N m (S.adjust f (m-i) xs)-mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs)--foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs-  where f' xs i x = f (m-i) x xs-foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs-  where f' xs i x = f (m-i) x xs--foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs-  where f' i x xs = f xs (m-i) x-foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs-  where f' i x xs = f xs (m-i) x--take i original@(N m xs)-  | i <= 0 = empty-  | i >  m = original-  | otherwise = N (i-1) (S.drop (m-i+1) xs)--drop i original@(N m xs)-  | i <= 0 = original-  | i >  m = empty-  | otherwise = N (m-i) (S.take (m-i+1) xs)--splitAt i original@(N m xs)-  | i <= 0 = (empty, original)-  | i >  m = (original, empty)-  | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs-                in (N (i-1) zs, N (m-i) ys)--subseq i len original@(N m xs)-  | i <= 0 = take len original-  | i >  m || len <= 0 = empty-  | i+len > m = N (m-i) (S.take (m-i+1) xs)-  | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs)--filter p = fromSeq . S.filter p . toSeq--partition p (N m xs) = (N (k-1) ys, N (m-k) zs)-  where (ys,zs) = S.partition p xs-        k = S.size ys--takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq-dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq--splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs))-  where (ys,zs) = S.splitWhile p (S.reverse xs)-        k = S.size ys--zip (N m xs) (N n ys)-  | m < n = N m (S.zip xs (S.drop (n-m) ys))-  | m > n = N n (S.zip (S.drop (m-n) xs) ys)-  | otherwise = N m (S.zip xs ys)-zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs')-  where k = min l (min m n)-        xs' = if l == k then xs else S.drop (l-k) xs-        ys' = if m == k then ys else S.drop (m-k) ys-        zs' = if n == k then zs else S.drop (n-k) zs--zipWith f (N m xs) (N n ys)-  | m < n = N m (S.zipWith f xs (S.drop (n-m) ys))-  | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys)-  | otherwise = N m (S.zipWith f xs ys)-zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs')-  where k = min l (min m n)-        xs' = if l == k then xs else S.drop (l-k) xs-        ys' = if m == k then ys else S.drop (m-k) ys-        zs' = if n == k then zs else S.drop (n-k) zs--unzip (N m xys) = (N m xs, N m ys)-  where (xs,ys) = S.unzip xys--unzip3 (N m xyzs) = (N m xs, N m ys, N m zs)-  where (xs,ys,zs) = S.unzip3 xyzs--unzipWith f g (N m xys) = (N m xs, N m ys)-  where (xs,ys) = S.unzipWith f g xys--unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs)-  where (xs,ys,zs) = S.unzipWith3 f g h xyzs--strict s@(N _ s') = S.strict s' `seq` s-strictWith f s@(N _ s') = S.strictWith f s' `seq` s--structuralInvariant (N i s) = i == ((S.size s) - 1)---- instances--instance S.Sequence s => S.Sequence (Rev s) where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName = instanceName}--instance S.Sequence s => Functor (Rev s) where-  fmap = map--instance S.Sequence s => App.Alternative (Rev s) where-  empty = empty-  (<|>) = append--instance S.Sequence s => App.Applicative (Rev s) where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance S.Sequence s => Monad (Rev s) where-  return = singleton-  xs >>= k = concatMap k xs--instance S.Sequence s => MonadPlus (Rev s) where-  mplus = append-  mzero = empty--instance Eq (s a) => Eq (Rev s a) where-  (N m xs) == (N n ys) = (m == n) && (xs == ys)--instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where-  compare = defaultCompare--instance (S.Sequence s, Show (s a)) => Show (Rev s a) where-  showsPrec i xs rest-     | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]-     | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]--instance (S.Sequence s, Read (s a)) => Read (Rev s a) where-  readsPrec _ xs = maybeParens p xs-      where p xs = tokenMatch (moduleName++".fromSeq") xs-                     >>= readsPrec 10-                     >>= \(l,rest) -> return (fromSeq l,rest)--instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Rev s a) where-  arbitrary = do xs <- arbitrary-                 return (fromSeq xs)--instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Rev s a) where-  coarbitrary xs = coarbitrary (toSeq xs)--instance S.Sequence s => Semigroup (Rev s a) where-  (<>) = append-instance S.Sequence s => Monoid (Rev s a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.RevSeq
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module defines a sequence adaptor @Rev s@.
+--   If @s@ is a sequence type constructor, then @Rev s@
+--   is a sequence type constructor that is identical to @s@,
+--   except that it is kept in the opposite order.
+--   Also keeps explicit track of the size of the sequence,
+--   similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq".
+--
+--   This module is most useful when s is a sequence type
+--   that offers fast access to the front but slow access
+--   to the rear, and your application needs the opposite
+--   (i.e., fast access to the rear but slow access to the
+--   front).
+--
+--   All time complexities are determined by the underlying
+--   sequence, except that the complexities for accessing
+--   the left and right sides of the sequence are exchanged,
+--   and size becomes @O( 1 )@.
+
+module Data.Edison.Seq.RevSeq (
+    -- * Rev Sequence Type
+    Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName,instanceName,
+
+    -- * Other supported operations
+    fromSeq,toSeq
+
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Seq.Defaults -- only used by concatMap
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Data.Monoid
+import Data.Semigroup as SG
+import Test.QuickCheck
+
+
+-- signatures for exported functions
+moduleName     :: String
+instanceName   :: S.Sequence s => Rev s a -> String
+empty          :: S.Sequence s => Rev s a
+singleton      :: S.Sequence s => a -> Rev s a
+lcons          :: S.Sequence s => a -> Rev s a -> Rev s a
+rcons          :: S.Sequence s => a -> Rev s a -> Rev s a
+append         :: S.Sequence s => Rev s a -> Rev s a -> Rev s a
+lview          :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a)
+lhead          :: S.Sequence s => Rev s a -> a
+lheadM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a
+ltail          :: S.Sequence s => Rev s a -> Rev s a
+ltailM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a)
+rview          :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a)
+rhead          :: S.Sequence s => Rev s a -> a
+rheadM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a
+rtail          :: S.Sequence s => Rev s a -> Rev s a
+rtailM         :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a)
+null           :: S.Sequence s => Rev s a -> Bool
+size           :: S.Sequence s => Rev s a -> Int
+concat         :: S.Sequence s => Rev s (Rev s a) -> Rev s a
+reverse        :: S.Sequence s => Rev s a -> Rev s a
+reverseOnto    :: S.Sequence s => Rev s a -> Rev s a -> Rev s a
+fromList       :: S.Sequence s => [a] -> Rev s a
+toList         :: S.Sequence s => Rev s a -> [a]
+map            :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b
+concatMap      :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b
+fold           :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b
+fold'          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b
+fold1          :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+fold1'         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+foldr          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b
+foldl          :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b
+foldr1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+foldl1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+reducer        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a
+reducel        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a
+reduce1        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b
+foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b
+foldr1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+foldl1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a
+reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a
+reduce1'       :: S.Sequence s => (a -> a -> a) -> Rev s a -> a
+copy           :: S.Sequence s => Int -> a -> Rev s a
+inBounds       :: S.Sequence s => Int -> Rev s a -> Bool
+lookup         :: S.Sequence s => Int -> Rev s a -> a
+lookupM        :: (S.Sequence s, Fail.MonadFail m) => Int -> Rev s a -> m a
+lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a
+update         :: S.Sequence s => Int -> a -> Rev s a -> Rev s a
+adjust         :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a
+mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b
+foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b
+foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b
+foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b
+foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b
+take           :: S.Sequence s => Int -> Rev s a -> Rev s a
+drop           :: S.Sequence s => Int -> Rev s a -> Rev s a
+splitAt        :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)
+subseq         :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a
+filter         :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a
+partition      :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)
+takeWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a
+dropWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a
+splitWhile     :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)
+zip            :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b)
+zip3           :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c)
+zipWith        :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c
+zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d
+unzip          :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b)
+unzip3         :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c)
+unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)
+unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)
+strict         :: S.Sequence s => Rev s a -> Rev s a
+strictWith     :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a
+structuralInvariant :: S.Sequence s => Rev s a -> Bool
+
+-- bonus functions, not in Sequence signature
+fromSeq        :: S.Sequence s => s a -> Rev s a
+toSeq          :: S.Sequence s => Rev s a -> s a
+
+
+moduleName = "Data.Edison.Seq.RevSeq"
+instanceName (N _ s) = "RevSeq(" ++ S.instanceName s ++ ")"
+
+data Rev s a = N !Int (s a)
+  -- The Int is the size minus one.  The "minus one" makes indexing
+  -- calculations easier.
+
+fromSeq xs = N (S.size xs - 1) xs
+toSeq (N _ xs) = xs
+
+empty = N (-1) S.empty
+singleton x = N 0 (S.singleton x)
+lcons x (N m xs) = N (m+1) (S.rcons x xs)
+rcons x (N m xs) = N (m+1) (S.lcons x xs)
+append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs)
+
+lview (N m xs) = case S.rview xs of
+                   Nothing     -> fail "RevSeq.lview: empty sequence"
+                   Just (x,xs) -> return (x, N (m-1) xs)
+
+lhead (N _ xs) = S.rhead xs
+
+lheadM (N _ xs) = S.rheadM xs
+
+ltail (N (-1) _) = error "RevSeq.ltail: empty sequence"
+ltail (N m xs) = N (m-1) (S.rtail xs)
+
+ltailM (N (-1) _) = fail "RevSeq.ltailM: empty sequence"
+ltailM (N m xs) = return (N (m-1) (S.rtail xs))
+
+rview (N m xs) = case S.lview xs of
+                   Nothing     -> fail "RevSeq.rview: empty sequence"
+                   Just (x,xs) -> return (x, N (m-1) xs)
+
+rhead (N _ xs) = S.lhead xs
+
+rheadM (N _ xs) = S.lheadM xs
+
+rtail (N (-1) _) = error "RevSeq.rtail: empty sequence"
+rtail (N m xs) = N (m-1) (S.ltail xs)
+
+rtailM (N (-1) _) = fail "RevSeq.rtailM: empty sequence"
+rtailM (N m xs) = return (N (m-1) (S.ltail xs))
+
+null (N m _) = m == -1
+size (N m _) = m+1
+concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))
+reverse (N m xs) = N m (S.reverse xs)
+reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs))
+fromList = fromSeq . S.fromList . L.reverse
+toList (N _ xs) = S.foldl (flip (:)) [] xs
+map f (N m xs) = N m (S.map f xs)
+
+concatMap = concatMapUsingFoldr -- only function that uses a default
+
+fold f e (N _ xs) = S.fold f e xs
+fold' f e (N _ xs) = S.fold' f e xs
+fold1 f (N _ xs) = S.fold1 f xs
+fold1' f (N _ xs) = S.fold1' f xs
+foldr f e (N _ xs) = S.foldl (flip f) e xs
+foldr' f e (N _ xs) = S.foldl' (flip f) e xs
+foldl f e (N _ xs) = S.foldr (flip f) e xs
+foldl' f e (N _ xs) = S.foldr' (flip f) e xs
+foldr1 f (N _ xs) = S.foldl1 (flip f) xs
+foldr1' f (N _ xs) = S.foldl1' (flip f) xs
+foldl1 f (N _ xs) = S.foldr1 (flip f) xs
+foldl1' f (N _ xs) = S.foldr1' (flip f) xs
+reducer f e (N _ xs) = S.reducel (flip f) e xs
+reducer' f e (N _ xs) = S.reducel' (flip f) e xs
+reducel f e (N _ xs) = S.reducer (flip f) e xs
+reducel' f e (N _ xs) = S.reducer' (flip f) e xs
+reduce1 f (N _ xs) = S.reduce1 (flip f) xs
+reduce1' f (N _ xs) = S.reduce1' (flip f) xs
+
+copy n x
+    | n <= 0 = empty
+    | otherwise = N (n-1) (S.copy n x)
+
+inBounds i (N m _) = (i >= 0) && (i <= m)
+lookup i (N m xs) = S.lookup (m-i) xs
+lookupM i (N m xs) = S.lookupM (m-i) xs
+lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs
+update i x (N m xs) = N m (S.update (m-i) x xs)
+adjust f i (N m xs) = N m (S.adjust f (m-i) xs)
+mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs)
+
+foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs
+  where f' xs i x = f (m-i) x xs
+foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs
+  where f' xs i x = f (m-i) x xs
+
+foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs
+  where f' i x xs = f xs (m-i) x
+foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs
+  where f' i x xs = f xs (m-i) x
+
+take i original@(N m xs)
+  | i <= 0 = empty
+  | i >  m = original
+  | otherwise = N (i-1) (S.drop (m-i+1) xs)
+
+drop i original@(N m xs)
+  | i <= 0 = original
+  | i >  m = empty
+  | otherwise = N (m-i) (S.take (m-i+1) xs)
+
+splitAt i original@(N m xs)
+  | i <= 0 = (empty, original)
+  | i >  m = (original, empty)
+  | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs
+                in (N (i-1) zs, N (m-i) ys)
+
+subseq i len original@(N m xs)
+  | i <= 0 = take len original
+  | i >  m || len <= 0 = empty
+  | i+len > m = N (m-i) (S.take (m-i+1) xs)
+  | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs)
+
+filter p = fromSeq . S.filter p . toSeq
+
+partition p (N m xs) = (N (k-1) ys, N (m-k) zs)
+  where (ys,zs) = S.partition p xs
+        k = S.size ys
+
+takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq
+dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq
+
+splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs))
+  where (ys,zs) = S.splitWhile p (S.reverse xs)
+        k = S.size ys
+
+zip (N m xs) (N n ys)
+  | m < n = N m (S.zip xs (S.drop (n-m) ys))
+  | m > n = N n (S.zip (S.drop (m-n) xs) ys)
+  | otherwise = N m (S.zip xs ys)
+zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs')
+  where k = min l (min m n)
+        xs' = if l == k then xs else S.drop (l-k) xs
+        ys' = if m == k then ys else S.drop (m-k) ys
+        zs' = if n == k then zs else S.drop (n-k) zs
+
+zipWith f (N m xs) (N n ys)
+  | m < n = N m (S.zipWith f xs (S.drop (n-m) ys))
+  | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys)
+  | otherwise = N m (S.zipWith f xs ys)
+zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs')
+  where k = min l (min m n)
+        xs' = if l == k then xs else S.drop (l-k) xs
+        ys' = if m == k then ys else S.drop (m-k) ys
+        zs' = if n == k then zs else S.drop (n-k) zs
+
+unzip (N m xys) = (N m xs, N m ys)
+  where (xs,ys) = S.unzip xys
+
+unzip3 (N m xyzs) = (N m xs, N m ys, N m zs)
+  where (xs,ys,zs) = S.unzip3 xyzs
+
+unzipWith f g (N m xys) = (N m xs, N m ys)
+  where (xs,ys) = S.unzipWith f g xys
+
+unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs)
+  where (xs,ys,zs) = S.unzipWith3 f g h xyzs
+
+strict s@(N _ s') = S.strict s' `seq` s
+strictWith f s@(N _ s') = S.strictWith f s' `seq` s
+
+structuralInvariant (N i s) = i == ((S.size s) - 1)
+
+-- instances
+
+instance S.Sequence s => S.Sequence (Rev s) where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName = instanceName}
+
+instance S.Sequence s => Functor (Rev s) where
+  fmap = map
+
+instance S.Sequence s => App.Alternative (Rev s) where
+  empty = empty
+  (<|>) = append
+
+instance S.Sequence s => App.Applicative (Rev s) where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance S.Sequence s => Monad (Rev s) where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance S.Sequence s => MonadPlus (Rev s) where
+  mplus = append
+  mzero = empty
+
+instance Eq (s a) => Eq (Rev s a) where
+  (N m xs) == (N n ys) = (m == n) && (xs == ys)
+
+instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where
+  compare = defaultCompare
+
+instance (S.Sequence s, Show (s a)) => Show (Rev s a) where
+  showsPrec i xs rest
+     | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]
+     | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]
+
+instance (S.Sequence s, Read (s a)) => Read (Rev s a) where
+  readsPrec _ xs = maybeParens p xs
+      where p xs = tokenMatch (moduleName++".fromSeq") xs
+                     >>= readsPrec 10
+                     >>= \(l,rest) -> return (fromSeq l,rest)
+
+instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Rev s a) where
+  arbitrary = do xs <- arbitrary
+                 return (fromSeq xs)
+
+instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Rev s a) where
+  coarbitrary xs = coarbitrary (toSeq xs)
+
+instance S.Sequence s => Semigroup (Rev s a) where
+  (<>) = append
+instance S.Sequence s => Monoid (Rev s a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/SimpleQueue.hs view

@@ -1,391 +1,391 @@--- |---   Module      :  Data.Edison.Seq.SimpleQueue---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   Simple Queues.  All operations have running times as listed in---   "Data.Edison.Seq" except for the following:------   * rcons, fromList   @O( 1 )@------   * lview, ltail*   @O( 1 )@ if single threaded, @O( n )@ otherwise------   * inBounds, lookup, update, drop, splitAt  @O( n )@------   /References:/------   * Chris Okasaki. /Purely Functional Data Structures/. 1998.---     Section 5.2.------   * F. Warren Burton. \"An efficient functional implementation of FIFO queues\".---     /Information Processing Letters/, 14(5):205-206, July 1982.--module Data.Edison.Seq.SimpleQueue (-    -- * Sequence Type-    Seq, -- instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck---- signatures for exported functions-moduleName     :: String-empty          :: Seq a-singleton      :: a -> Seq a-lcons          :: a -> Seq a -> Seq a-rcons          :: a -> Seq a -> Seq a-append         :: Seq a -> Seq a -> Seq a-lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-lhead          :: Seq a -> a-lheadM         :: (Fail.MonadFail m) => Seq a -> m a-ltail          :: Seq a -> Seq a-ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)-rhead          :: Seq a -> a-rheadM         :: (Fail.MonadFail m) => Seq a -> m a-rtail          :: Seq a -> Seq a-rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)-null           :: Seq a -> Bool-size           :: Seq a -> Int-concat         :: Seq (Seq a) -> Seq a-reverse        :: Seq a -> Seq a-reverseOnto    :: Seq a -> Seq a -> Seq a-fromList       :: [a] -> Seq a-toList         :: Seq a -> [a]-map            :: (a -> b) -> Seq a -> Seq b-concatMap      :: (a -> Seq b) -> Seq a -> Seq b-fold           :: (a -> b -> b) -> b -> Seq a -> b-fold'          :: (a -> b -> b) -> b -> Seq a -> b-fold1          :: (a -> a -> a) -> Seq a -> a-fold1'         :: (a -> a -> a) -> Seq a -> a-foldr          :: (a -> b -> b) -> b -> Seq a -> b-foldl          :: (b -> a -> b) -> b -> Seq a -> b-foldr1         :: (a -> a -> a) -> Seq a -> a-foldl1         :: (a -> a -> a) -> Seq a -> a-reducer        :: (a -> a -> a) -> a -> Seq a -> a-reducel        :: (a -> a -> a) -> a -> Seq a -> a-reduce1        :: (a -> a -> a) -> Seq a -> a-foldr'         :: (a -> b -> b) -> b -> Seq a -> b-foldl'         :: (b -> a -> b) -> b -> Seq a -> b-foldr1'        :: (a -> a -> a) -> Seq a -> a-foldl1'        :: (a -> a -> a) -> Seq a -> a-reducer'       :: (a -> a -> a) -> a -> Seq a -> a-reducel'       :: (a -> a -> a) -> a -> Seq a -> a-reduce1'       :: (a -> a -> a) -> Seq a -> a-copy           :: Int -> a -> Seq a-inBounds       :: Int -> Seq a -> Bool-lookup         :: Int -> Seq a -> a-lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update         :: Int -> a -> Seq a -> Seq a-adjust         :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take           :: Int -> Seq a -> Seq a-drop           :: Int -> Seq a -> Seq a-splitAt        :: Int -> Seq a -> (Seq a, Seq a)-subseq         :: Int -> Int -> Seq a -> Seq a-filter         :: (a -> Bool) -> Seq a -> Seq a-partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile      :: (a -> Bool) -> Seq a -> Seq a-dropWhile      :: (a -> Bool) -> Seq a -> Seq a-splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip            :: Seq a -> Seq b -> Seq (a,b)-zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip          :: Seq (a,b) -> (Seq a, Seq b)-unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict         :: Seq a -> Seq a-strictWith     :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.SimpleQueue"---data Seq a = Q [a] [a]-  -- invariant: front empty only if rear also empty---- not exported-makeQ :: [a] -> [a] -> Seq a-makeQ [] ys = Q (L.reverse ys) []-makeQ xs ys = Q xs ys--empty = Q [] []-singleton x = Q [x] []-lcons x (Q xs ys) = Q (x:xs) ys--rcons y (Q [] _) = Q [y] []-rcons y (Q xs ys) = Q xs (y:ys)--append (Q xs1 ys1) (Q xs2 ys2) =-    Q (xs1 ++ L.reverseOnto ys1 xs2) ys2--lview (Q [] _) = fail "SimpleQueue.lview: empty sequence"-lview (Q [x] ys) = return (x, Q (L.reverse ys) [])-lview (Q (x:xs) ys) = return (x, Q xs ys)--lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence"-lhead (Q (x:_) _) = x--lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence"-lheadM (Q (x:_) _) = return x--ltail (Q [_] ys) = Q (L.reverse ys) []-ltail (Q (_:xs) ys) = Q xs ys-ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence"--ltailM (Q [_] ys) = return (Q (L.reverse ys) [])-ltailM (Q (_:xs) ys) = return (Q xs ys)-ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence"--rview (Q xs (y:ys)) = return (y, Q xs ys)-rview (Q xs []) =-  case L.rview xs of-    Nothing      -> fail "SimpleQueue.rview: empty sequence"-    Just (x,xs') -> return (x, Q xs' [])--rhead (Q _ (y:_)) = y-rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence"-rhead (Q xs []) = L.rhead xs--rheadM (Q _ (y:_)) = return y-rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence"-rheadM (Q xs []) = return (L.rhead xs)--rtail (Q xs (_:ys)) = Q xs ys-rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence"-rtail (Q xs []) = Q (L.rtail xs) []--rtailM (Q xs (_:ys)) = return (Q xs ys)-rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence"-rtailM (Q xs []) = return (Q (L.rtail xs) [])--null (Q [] _) = True-null _ = False--size (Q xs ys) = length xs + length ys--reverse (Q xs []) = Q (L.reverse xs) []-reverse (Q xs ys) = Q ys xs--reverseOnto (Q xs1 ys1) (Q xs2 ys2) =-    Q (ys1 ++ L.reverseOnto xs1 xs2) ys2--fromList xs = Q xs []--toList (Q xs []) = xs-toList (Q xs ys) = xs ++ L.reverse ys--map f (Q xs ys) = Q (L.map f xs) (L.map f ys)---- local fn on lists-revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1-revfoldr _ e [] = e-revfoldr f e (x:xs) = revfoldr f (f x e) xs--revfoldr' :: (t -> a -> a) -> a -> [t] -> a-revfoldr' _ e [] = e-revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs---- local fn on lists-revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t-revfoldl _ e [] = e-revfoldl f e (x:xs) = f (revfoldl f e xs) x--revfoldl' :: (a -> t -> a) -> a -> [t] -> a-revfoldl' _ e [] = e-revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x--fold   f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs-fold'  f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs-fold1  = fold1UsingFold-fold1' = fold1'UsingFold'--foldr  f e (Q xs ys) = L.foldr  f (revfoldr  f e ys) xs-foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs--foldl  f e (Q xs ys) = revfoldl  f (L.foldl  f e xs) ys-foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys--foldr1  f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs-foldr1  _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence"-foldr1  f (Q xs []) = L.foldr1 f xs--foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs-foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence"-foldr1' f (Q xs []) = L.foldr1' f xs--foldl1  f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys-foldl1  _ (Q [] _) = error "SimpleQueue.foldl1: empty sequence"--foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys-foldl1' _ (Q [] _) = error "SimpleQueue.foldl1': empty sequence"--filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys)--partition p (Q xs ys)-  = (makeQ xsT ysT, makeQ xsF ysF)- where-   (xsT,xsF) = L.partition p xs-   (ysT,ysF) = L.partition p ys--strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s-strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s---- the remaining functions all use defaults--concat = concatUsingFoldr-concatMap = concatMapUsingFoldr-reducer  = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel  = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1  = reduce1UsingLists-reduce1' = reduce1'UsingLists-copy = copyUsingLists-inBounds = inBoundsUsingLookupM-lookup = lookupUsingLookupM-lookupM = lookupMUsingDrop-lookupWithDefault = lookupWithDefaultUsingLookupM-update = updateUsingAdjust-adjust = adjustUsingLists-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex  = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex  = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-drop = dropUsingLists-splitAt = splitAtDefault-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview-zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- invariant:---   * front empty only if rear also empty--structuralInvariant (Q x y) = not (L.null x) || L.null y---- instances--instance S.Sequence Seq where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where-  fmap = map--instance App.Alternative Seq where-  empty = empty-  (<|>) = append--instance App.Applicative Seq where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance Monad Seq where-  return = singleton-  xs >>= k = concatMap k xs--instance MonadPlus Seq where-  mplus = append-  mzero = empty--instance Eq a => Eq (Seq a) where-  q1 == q2 = toList q1 == toList q2--instance Ord a => Ord (Seq a) where-  compare = defaultCompare--instance Show a => Show (Seq a) where-  showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where-  readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where-  arbitrary = do xs <- arbitrary-                 ys <- arbitrary-                 return (if L.null xs then Q ys [] else Q xs ys)--instance CoArbitrary a => CoArbitrary (Seq a) where-  coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys--instance Semigroup (Seq a) where-  (<>) = append-instance Monoid (Seq a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.SimpleQueue
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   Simple Queues.  All operations have running times as listed in
+--   "Data.Edison.Seq" except for the following:
+--
+--   * rcons, fromList   @O( 1 )@
+--
+--   * lview, ltail*   @O( 1 )@ if single threaded, @O( n )@ otherwise
+--
+--   * inBounds, lookup, update, drop, splitAt  @O( n )@
+--
+--   /References:/
+--
+--   * Chris Okasaki. /Purely Functional Data Structures/. 1998.
+--     Section 5.2.
+--
+--   * F. Warren Burton. \"An efficient functional implementation of FIFO queues\".
+--     /Information Processing Letters/, 14(5):205-206, July 1982.
+
+module Data.Edison.Seq.SimpleQueue (
+    -- * Sequence Type
+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+
+import qualified Data.Edison.Seq as S ( Sequence(..) )
+import Data.Edison.Seq.Defaults
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+-- signatures for exported functions
+moduleName     :: String
+empty          :: Seq a
+singleton      :: a -> Seq a
+lcons          :: a -> Seq a -> Seq a
+rcons          :: a -> Seq a -> Seq a
+append         :: Seq a -> Seq a -> Seq a
+lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+lhead          :: Seq a -> a
+lheadM         :: (Fail.MonadFail m) => Seq a -> m a
+ltail          :: Seq a -> Seq a
+ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
+rhead          :: Seq a -> a
+rheadM         :: (Fail.MonadFail m) => Seq a -> m a
+rtail          :: Seq a -> Seq a
+rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
+null           :: Seq a -> Bool
+size           :: Seq a -> Int
+concat         :: Seq (Seq a) -> Seq a
+reverse        :: Seq a -> Seq a
+reverseOnto    :: Seq a -> Seq a -> Seq a
+fromList       :: [a] -> Seq a
+toList         :: Seq a -> [a]
+map            :: (a -> b) -> Seq a -> Seq b
+concatMap      :: (a -> Seq b) -> Seq a -> Seq b
+fold           :: (a -> b -> b) -> b -> Seq a -> b
+fold'          :: (a -> b -> b) -> b -> Seq a -> b
+fold1          :: (a -> a -> a) -> Seq a -> a
+fold1'         :: (a -> a -> a) -> Seq a -> a
+foldr          :: (a -> b -> b) -> b -> Seq a -> b
+foldl          :: (b -> a -> b) -> b -> Seq a -> b
+foldr1         :: (a -> a -> a) -> Seq a -> a
+foldl1         :: (a -> a -> a) -> Seq a -> a
+reducer        :: (a -> a -> a) -> a -> Seq a -> a
+reducel        :: (a -> a -> a) -> a -> Seq a -> a
+reduce1        :: (a -> a -> a) -> Seq a -> a
+foldr'         :: (a -> b -> b) -> b -> Seq a -> b
+foldl'         :: (b -> a -> b) -> b -> Seq a -> b
+foldr1'        :: (a -> a -> a) -> Seq a -> a
+foldl1'        :: (a -> a -> a) -> Seq a -> a
+reducer'       :: (a -> a -> a) -> a -> Seq a -> a
+reducel'       :: (a -> a -> a) -> a -> Seq a -> a
+reduce1'       :: (a -> a -> a) -> Seq a -> a
+copy           :: Int -> a -> Seq a
+inBounds       :: Int -> Seq a -> Bool
+lookup         :: Int -> Seq a -> a
+lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
+lookupWithDefault :: a -> Int -> Seq a -> a
+update         :: Int -> a -> Seq a -> Seq a
+adjust         :: (a -> a) -> Int -> Seq a -> Seq a
+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
+take           :: Int -> Seq a -> Seq a
+drop           :: Int -> Seq a -> Seq a
+splitAt        :: Int -> Seq a -> (Seq a, Seq a)
+subseq         :: Int -> Int -> Seq a -> Seq a
+filter         :: (a -> Bool) -> Seq a -> Seq a
+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+takeWhile      :: (a -> Bool) -> Seq a -> Seq a
+dropWhile      :: (a -> Bool) -> Seq a -> Seq a
+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+zip            :: Seq a -> Seq b -> Seq (a,b)
+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+unzip          :: Seq (a,b) -> (Seq a, Seq b)
+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
+strict         :: Seq a -> Seq a
+strictWith     :: (a -> b) -> Seq a -> Seq a
+structuralInvariant :: Seq a -> Bool
+
+moduleName = "Data.Edison.Seq.SimpleQueue"
+
+
+data Seq a = Q [a] [a]
+  -- invariant: front empty only if rear also empty
+
+-- not exported
+makeQ :: [a] -> [a] -> Seq a
+makeQ [] ys = Q (L.reverse ys) []
+makeQ xs ys = Q xs ys
+
+empty = Q [] []
+singleton x = Q [x] []
+lcons x (Q xs ys) = Q (x:xs) ys
+
+rcons y (Q [] _) = Q [y] []
+rcons y (Q xs ys) = Q xs (y:ys)
+
+append (Q xs1 ys1) (Q xs2 ys2) =
+    Q (xs1 ++ L.reverseOnto ys1 xs2) ys2
+
+lview (Q [] _) = fail "SimpleQueue.lview: empty sequence"
+lview (Q [x] ys) = return (x, Q (L.reverse ys) [])
+lview (Q (x:xs) ys) = return (x, Q xs ys)
+
+lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence"
+lhead (Q (x:_) _) = x
+
+lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence"
+lheadM (Q (x:_) _) = return x
+
+ltail (Q [_] ys) = Q (L.reverse ys) []
+ltail (Q (_:xs) ys) = Q xs ys
+ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence"
+
+ltailM (Q [_] ys) = return (Q (L.reverse ys) [])
+ltailM (Q (_:xs) ys) = return (Q xs ys)
+ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence"
+
+rview (Q xs (y:ys)) = return (y, Q xs ys)
+rview (Q xs []) =
+  case L.rview xs of
+    Nothing      -> fail "SimpleQueue.rview: empty sequence"
+    Just (x,xs') -> return (x, Q xs' [])
+
+rhead (Q _ (y:_)) = y
+rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence"
+rhead (Q xs []) = L.rhead xs
+
+rheadM (Q _ (y:_)) = return y
+rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence"
+rheadM (Q xs []) = return (L.rhead xs)
+
+rtail (Q xs (_:ys)) = Q xs ys
+rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence"
+rtail (Q xs []) = Q (L.rtail xs) []
+
+rtailM (Q xs (_:ys)) = return (Q xs ys)
+rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence"
+rtailM (Q xs []) = return (Q (L.rtail xs) [])
+
+null (Q [] _) = True
+null _ = False
+
+size (Q xs ys) = length xs + length ys
+
+reverse (Q xs []) = Q (L.reverse xs) []
+reverse (Q xs ys) = Q ys xs
+
+reverseOnto (Q xs1 ys1) (Q xs2 ys2) =
+    Q (ys1 ++ L.reverseOnto xs1 xs2) ys2
+
+fromList xs = Q xs []
+
+toList (Q xs []) = xs
+toList (Q xs ys) = xs ++ L.reverse ys
+
+map f (Q xs ys) = Q (L.map f xs) (L.map f ys)
+
+-- local fn on lists
+revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1
+revfoldr _ e [] = e
+revfoldr f e (x:xs) = revfoldr f (f x e) xs
+
+revfoldr' :: (t -> a -> a) -> a -> [t] -> a
+revfoldr' _ e [] = e
+revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs
+
+-- local fn on lists
+revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t
+revfoldl _ e [] = e
+revfoldl f e (x:xs) = f (revfoldl f e xs) x
+
+revfoldl' :: (a -> t -> a) -> a -> [t] -> a
+revfoldl' _ e [] = e
+revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x
+
+fold   f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs
+fold'  f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs
+fold1  = fold1UsingFold
+fold1' = fold1'UsingFold'
+
+foldr  f e (Q xs ys) = L.foldr  f (revfoldr  f e ys) xs
+foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs
+
+foldl  f e (Q xs ys) = revfoldl  f (L.foldl  f e xs) ys
+foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys
+
+foldr1  f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs
+foldr1  _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence"
+foldr1  f (Q xs []) = L.foldr1 f xs
+
+foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs
+foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence"
+foldr1' f (Q xs []) = L.foldr1' f xs
+
+foldl1  f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys
+foldl1  _ (Q [] _) = error "SimpleQueue.foldl1: empty sequence"
+
+foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys
+foldl1' _ (Q [] _) = error "SimpleQueue.foldl1': empty sequence"
+
+filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys)
+
+partition p (Q xs ys)
+  = (makeQ xsT ysT, makeQ xsF ysF)
+ where
+   (xsT,xsF) = L.partition p xs
+   (ysT,ysF) = L.partition p ys
+
+strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s
+strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s
+
+-- the remaining functions all use defaults
+
+concat = concatUsingFoldr
+concatMap = concatMapUsingFoldr
+reducer  = reducerUsingReduce1
+reducer' = reducer'UsingReduce1'
+reducel  = reducelUsingReduce1
+reducel' = reducel'UsingReduce1'
+reduce1  = reduce1UsingLists
+reduce1' = reduce1'UsingLists
+copy = copyUsingLists
+inBounds = inBoundsUsingLookupM
+lookup = lookupUsingLookupM
+lookupM = lookupMUsingDrop
+lookupWithDefault = lookupWithDefaultUsingLookupM
+update = updateUsingAdjust
+adjust = adjustUsingLists
+mapWithIndex = mapWithIndexUsingLists
+foldrWithIndex  = foldrWithIndexUsingLists
+foldrWithIndex' = foldrWithIndex'UsingLists
+foldlWithIndex  = foldlWithIndexUsingLists
+foldlWithIndex' = foldlWithIndex'UsingLists
+take = takeUsingLists
+drop = dropUsingLists
+splitAt = splitAtDefault
+subseq = subseqDefault
+takeWhile = takeWhileUsingLview
+dropWhile = dropWhileUsingLview
+splitWhile = splitWhileUsingLview
+zip = zipUsingLists
+zip3 = zip3UsingLists
+zipWith = zipWithUsingLists
+zipWith3 = zipWith3UsingLists
+unzip = unzipUsingLists
+unzip3 = unzip3UsingLists
+unzipWith = unzipWithUsingLists
+unzipWith3 = unzipWith3UsingLists
+
+-- invariant:
+--   * front empty only if rear also empty
+
+structuralInvariant (Q x y) = not (L.null x) || L.null y
+
+-- instances
+
+instance S.Sequence Seq where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName _ = moduleName}
+
+instance Functor Seq where
+  fmap = map
+
+instance App.Alternative Seq where
+  empty = empty
+  (<|>) = append
+
+instance App.Applicative Seq where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance Monad Seq where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance MonadPlus Seq where
+  mplus = append
+  mzero = empty
+
+instance Eq a => Eq (Seq a) where
+  q1 == q2 = toList q1 == toList q2
+
+instance Ord a => Ord (Seq a) where
+  compare = defaultCompare
+
+instance Show a => Show (Seq a) where
+  showsPrec = showsPrecUsingToList
+
+instance Read a => Read (Seq a) where
+  readsPrec = readsPrecUsingFromList
+
+instance Arbitrary a => Arbitrary (Seq a) where
+  arbitrary = do xs <- arbitrary
+                 ys <- arbitrary
+                 return (if L.null xs then Q ys [] else Q xs ys)
+
+instance CoArbitrary a => CoArbitrary (Seq a) where
+  coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys
+
+instance Semigroup (Seq a) where
+  (<>) = append
+instance Monoid (Seq a) where
+  mempty  = empty
+  mappend = (SG.<>)

src/Data/Edison/Seq/SizedSeq.hs view

@@ -1,373 +1,373 @@--- |---   Module      :  Data.Edison.Seq.SizedSeq---   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki---   License     :  MIT; see COPYRIGHT file for terms and conditions------   Maintainer  :  robdockins AT fastmail DOT fm---   Stability   :  stable---   Portability :  GHC, Hugs (MPTC and FD)------   This module defines a sequence adaptor @Sized s@.---   If @s@ is a sequence type constructor, then @Sized s@---   is a sequence type constructor that is identical to @s@,---   except that it also keeps track of the current size of---   each sequence.------   All time complexities are determined by the underlying---   sequence, except that size becomes @O( 1 )@.--module Data.Edison.Seq.SizedSeq (-    -- * Sized Sequence Type-    Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus--    -- * Sequence Operations-    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,-    lheadM,ltailM,rheadM,rtailM,-    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,-    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',-    reducer,reducer',reducel,reducel',reduce1,reduce1',-    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,-    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',-    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,-    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,-    strict, strictWith,--    -- * Unit testing-    structuralInvariant,--    -- * Documentation-    moduleName,instanceName,--    -- * Other supported operations-    fromSeq,toSeq-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',-                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,-                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Control.Applicative as App--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults -- only used by concatMap-import Data.Monoid-import Data.Semigroup as SG-import Control.Monad-import qualified Control.Monad.Fail as Fail-import Test.QuickCheck----- signatures for exported functions-moduleName     :: String-instanceName   :: S.Sequence s => Sized s a -> String-empty          :: S.Sequence s => Sized s a-singleton      :: S.Sequence s => a -> Sized s a-lcons          :: S.Sequence s => a -> Sized s a -> Sized s a-rcons          :: S.Sequence s => a -> Sized s a -> Sized s a-append         :: S.Sequence s => Sized s a -> Sized s a -> Sized s a-lview          :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a)-lhead          :: S.Sequence s => Sized s a -> a-lheadM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a-ltail          :: S.Sequence s => Sized s a -> Sized s a-ltailM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a)-rview          :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a)-rhead          :: S.Sequence s => Sized s a -> a-rheadM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a-rtail          :: S.Sequence s => Sized s a -> Sized s a-rtailM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a)-null           :: S.Sequence s => Sized s a -> Bool-size           :: S.Sequence s => Sized s a -> Int-concat         :: S.Sequence s => Sized s (Sized s a) -> Sized s a-reverse        :: S.Sequence s => Sized s a -> Sized s a-reverseOnto    :: S.Sequence s => Sized s a -> Sized s a -> Sized s a-fromList       :: S.Sequence s => [a] -> Sized s a-toList         :: S.Sequence s => Sized s a -> [a]-map            :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b-concatMap      :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b-fold           :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-fold'          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-fold1          :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-fold1'         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldr          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-foldl          :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b-foldr1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldl1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-reducer        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reducel        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reduce1        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b-foldr1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldl1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reduce1'       :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-copy           :: S.Sequence s => Int -> a -> Sized s a-inBounds       :: S.Sequence s => Int -> Sized s a -> Bool-lookup         :: S.Sequence s => Int -> Sized s a -> a-lookupM        :: (S.Sequence s, Fail.MonadFail m) => Int -> Sized s a -> m a-lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a-update         :: S.Sequence s => Int -> a -> Sized s a -> Sized s a-adjust         :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a-mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b-foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b-foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b-foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b-foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b-take           :: S.Sequence s => Int -> Sized s a -> Sized s a-drop           :: S.Sequence s => Int -> Sized s a -> Sized s a-splitAt        :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)-subseq         :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a-filter         :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-partition      :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)-takeWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-dropWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-splitWhile     :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)-zip            :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b)-zip3           :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c)-zipWith        :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c-zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d-unzip          :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b)-unzip3         :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c)-unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)-unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)-strict         :: S.Sequence s => Sized s a -> Sized s a-strictWith     :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a-structuralInvariant :: S.Sequence s => Sized s a -> Bool---- bonus functions, not in Sequence signature-fromSeq        :: S.Sequence s => s a -> Sized s a-toSeq          :: S.Sequence s => Sized s a -> s a----moduleName = "Data.Edison.Seq.SizedSeq"-instanceName (N _ s) = "SizedSeq(" ++ S.instanceName s ++ ")"--data Sized s a = N !Int (s a)--fromSeq xs = N (S.size xs) xs-toSeq (N _ xs) = xs--empty = N 0 S.empty-singleton x = N 1 (S.singleton x)-lcons x (N n xs) = N (n+1) (S.lcons x xs)-rcons x (N n xs) = N (n+1) (S.rcons x xs)-append (N m xs) (N n ys) = N (m+n) (S.append xs ys)--lview (N n xs) = case S.lview xs of-                   Nothing     -> fail "SizedSeq.lview: empty sequence"-                   Just (x,xs) -> return (x, N (n-1) xs)--lhead (N _ xs) = S.lhead xs--lheadM (N _ xs) = S.lheadM xs--ltail (N 0 _) = error "SizedSeq.ltail: empty sequence"-ltail (N n xs) = N (n-1) (S.ltail xs)--ltailM (N 0 _) = fail "SizedSeq.ltailM: empty sequence"-ltailM (N n xs) = return (N (n-1) (S.ltail xs))--rview (N n xs) = case S.rview xs of-                   Nothing     -> fail "SizedSeq.rview: empty sequence"-                   Just (x,xs) -> return (x, N (n-1) xs)--rhead (N _ xs) = S.rhead xs--rheadM (N _ xs) = S.rheadM xs--rtail (N 0 _) = error "SizedSeq.rtail: empty sequence"-rtail (N n xs) = N (n-1) (S.rtail xs)--rtailM (N 0 _) = fail "SizedSeq.rtailM: empty sequence"-rtailM (N n xs) = return (N (n-1) (S.rtail xs))--null (N n _) = n == 0-size (N n _) = n-concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))-reverse (N n xs) = N n (S.reverse xs)-reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys)-fromList = fromSeq . S.fromList-toList (N _ xs) = S.toList xs-map f (N n xs) = N n (S.map f xs)--concatMap = concatMapUsingFoldr -- only function that uses a default--fold  f e (N _ xs) = S.fold f e xs-fold' f e (N _ xs) = S.fold' f e xs-fold1 f  (N _ xs) = S.fold1 f xs-fold1' f (N _ xs) = S.fold1' f xs-foldr  f e (N _ xs) = S.foldr f e xs-foldr' f e (N _ xs) = S.foldr' f e xs-foldl  f e (N _ xs) = S.foldl f e xs-foldl' f e (N _ xs) = S.foldl' f e xs-foldr1  f (N _ xs) = S.foldr1 f xs-foldr1' f (N _ xs) = S.foldr1' f xs-foldl1  f (N _ xs) = S.foldl1 f xs-foldl1' f (N _ xs) = S.foldl1' f xs-reducer  f e (N _ xs) = S.reducer f e xs-reducer' f e (N _ xs) = S.reducer' f e xs-reducel  f e (N _ xs) = S.reducel f e xs-reducel' f e (N _ xs) = S.reducel' f e xs-reduce1  f (N _ xs) = S.reduce1 f xs-reduce1' f (N _ xs) = S.reduce1' f xs--copy n x-    | n <= 0 = empty-    | otherwise = N n (S.copy n x)--inBounds i (N n _) = (i >= 0) && (i < n)-lookup i (N _ xs) = S.lookup i xs-lookupM i (N _ xs) = S.lookupM i xs-lookupWithDefault d i (N _ xs) = S.lookupWithDefault d i xs-update i x (N n xs) = N n (S.update i x xs)-adjust f i (N n xs) = N n (S.adjust f i xs)-mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs)-foldrWithIndex  f e (N _ xs) = S.foldrWithIndex f e xs-foldrWithIndex' f e (N _ xs) = S.foldrWithIndex' f e xs-foldlWithIndex  f e (N _ xs) = S.foldlWithIndex f e xs-foldlWithIndex' f e (N _ xs) = S.foldlWithIndex' f e xs--take i original@(N n xs)-  | i <= 0 = empty-  | i >= n = original-  | otherwise = N i (S.take i xs)--drop i original@(N n xs)-  | i <= 0 = original-  | i >= n = empty-  | otherwise = N (n-i) (S.drop i xs)--splitAt i original@(N n xs)-  | i <= 0 = (empty, original)-  | i >= n = (original, empty)-  | otherwise = let (ys,zs) = S.splitAt i xs-                in (N i ys, N (n-i) zs)--subseq i len original@(N n xs)-  | i <= 0 = take len original-  | i >= n || len <= 0 = empty-  | i+len >= n = N (n-i) (S.drop i xs)-  | otherwise = N len (S.subseq i len xs)--filter p = fromSeq . S.filter p . toSeq--partition p (N n xs) = (N m ys, N (n-m) zs)-  where (ys,zs) = S.partition p xs-        m = S.size ys--takeWhile p = fromSeq . S.takeWhile p . toSeq-dropWhile p = fromSeq . S.dropWhile p . toSeq--splitWhile p (N n xs) = (N m ys, N (n-m) zs)-  where (ys,zs) = S.splitWhile p xs-        m = S.size ys--zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys)-zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs)--zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys)-zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs)--unzip (N n xys) = (N n xs, N n ys)-  where (xs,ys) = S.unzip xys--unzip3 (N n xyzs) = (N n xs, N n ys, N n zs)-  where (xs,ys,zs) = S.unzip3 xyzs--unzipWith f g (N n xys) = (N n xs, N n ys)-  where (xs,ys) = S.unzipWith f g xys--unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs)-  where (xs,ys,zs) = S.unzipWith3 f g h xyzs--strict s@(N _ s') = S.strict s' `seq` s-strictWith f s@(N _ s') = S.strictWith f s' `seq` s--structuralInvariant (N i s) = i == S.size s---- instances--instance S.Sequence s => S.Sequence (Sized s) where-  {lcons = lcons; rcons = rcons;-   lview = lview; lhead = lhead; ltail = ltail;-   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;-   rview = rview; rhead = rhead; rtail = rtail; null = null;-   size = size; concat = concat; reverse = reverse;-   reverseOnto = reverseOnto; fromList = fromList; toList = toList;-   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';-   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';-   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';-   reducer = reducer; reducer' = reducer'; reducel = reducel;-   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';-   copy = copy; inBounds = inBounds; lookup = lookup;-   lookupM = lookupM; lookupWithDefault = lookupWithDefault;-   update = update; adjust = adjust; mapWithIndex = mapWithIndex;-   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';-   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';-   take = take; drop = drop; splitAt = splitAt; subseq = subseq;-   filter = filter; partition = partition; takeWhile = takeWhile;-   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;-   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;-   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;-   strict = strict; strictWith = strictWith;-   structuralInvariant = structuralInvariant; instanceName = instanceName}--instance S.Sequence s => Functor (Sized s) where-  fmap = map--instance S.Sequence s => App.Alternative (Sized s) where-  empty = empty-  (<|>) = append--instance S.Sequence s => App.Applicative (Sized s) where-  pure = return-  x <*> y = do-     x' <- x-     y' <- y-     return (x' y')--instance S.Sequence s => Monad (Sized s) where-  return = singleton-  xs >>= k = concatMap k xs--instance S.Sequence s => MonadPlus (Sized s) where-  mplus = append-  mzero = empty---instance Eq (s a) => Eq (Sized s a) where-  (N m xs) == (N n ys) = (m == n) && (xs == ys)-  -- this is probably identical to the code that would be-  -- generated by "deriving (Eq)", but I wanted to be *sure*-  -- that the sizes were compared before the inner sequences--instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where-  compare = defaultCompare--instance (S.Sequence s, Show (s a)) => Show (Sized s a) where-  showsPrec i xs rest-    | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]-    | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]--instance (S.Sequence s, Read (s a)) => Read (Sized s a) where-  readsPrec _ xs = maybeParens p xs-      where p xs = tokenMatch (moduleName++".fromSeq") xs-                     >>= readsPrec 10-                     >>= \(l,rest) -> return (fromSeq l, rest)--instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Sized s a) where-  arbitrary = do xs <- arbitrary-                 return (fromSeq xs)--instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Sized s a) where-  coarbitrary xs = coarbitrary (toSeq xs)---instance S.Sequence s => Semigroup (Sized s a) where-  (<>) = append-instance S.Sequence s => Monoid (Sized s a) where-  mempty  = empty-  mappend = (SG.<>)+-- |
+--   Module      :  Data.Edison.Seq.SizedSeq
+--   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
+--   License     :  MIT; see COPYRIGHT file for terms and conditions
+--
+--   Maintainer  :  robdockins AT fastmail DOT fm
+--   Stability   :  stable
+--   Portability :  GHC, Hugs (MPTC and FD)
+--
+--   This module defines a sequence adaptor @Sized s@.
+--   If @s@ is a sequence type constructor, then @Sized s@
+--   is a sequence type constructor that is identical to @s@,
+--   except that it also keeps track of the current size of
+--   each sequence.
+--
+--   All time complexities are determined by the underlying
+--   sequence, except that size becomes @O( 1 )@.
+
+module Data.Edison.Seq.SizedSeq (
+    -- * Sized Sequence Type
+    Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus
+
+    -- * Sequence Operations
+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
+    lheadM,ltailM,rheadM,rtailM,
+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
+    reducer,reducer',reducel,reducel',reduce1,reduce1',
+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
+    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',
+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
+    strict, strictWith,
+
+    -- * Unit testing
+    structuralInvariant,
+
+    -- * Documentation
+    moduleName,instanceName,
+
+    -- * Other supported operations
+    fromSeq,toSeq
+) where
+
+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
+
+import qualified Control.Applicative as App
+
+import qualified Data.Edison.Seq as S
+import qualified Data.Edison.Seq.ListSeq as L
+import Data.Edison.Seq.Defaults -- only used by concatMap
+import Data.Monoid
+import Data.Semigroup as SG
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Test.QuickCheck
+
+
+-- signatures for exported functions
+moduleName     :: String
+instanceName   :: S.Sequence s => Sized s a -> String
+empty          :: S.Sequence s => Sized s a
+singleton      :: S.Sequence s => a -> Sized s a
+lcons          :: S.Sequence s => a -> Sized s a -> Sized s a
+rcons          :: S.Sequence s => a -> Sized s a -> Sized s a
+append         :: S.Sequence s => Sized s a -> Sized s a -> Sized s a
+lview          :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a)
+lhead          :: S.Sequence s => Sized s a -> a
+lheadM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a
+ltail          :: S.Sequence s => Sized s a -> Sized s a
+ltailM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a)
+rview          :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a)
+rhead          :: S.Sequence s => Sized s a -> a
+rheadM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a
+rtail          :: S.Sequence s => Sized s a -> Sized s a
+rtailM         :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a)
+null           :: S.Sequence s => Sized s a -> Bool
+size           :: S.Sequence s => Sized s a -> Int
+concat         :: S.Sequence s => Sized s (Sized s a) -> Sized s a
+reverse        :: S.Sequence s => Sized s a -> Sized s a
+reverseOnto    :: S.Sequence s => Sized s a -> Sized s a -> Sized s a
+fromList       :: S.Sequence s => [a] -> Sized s a
+toList         :: S.Sequence s => Sized s a -> [a]
+map            :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b
+concatMap      :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b
+fold           :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b
+fold'          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b
+fold1          :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+fold1'         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+foldr          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b
+foldl          :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b
+foldr1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+foldl1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+reducer        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a
+reducel        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a
+reduce1        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b
+foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b
+foldr1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+foldl1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a
+reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a
+reduce1'       :: S.Sequence s => (a -> a -> a) -> Sized s a -> a
+copy           :: S.Sequence s => Int -> a -> Sized s a
+inBounds       :: S.Sequence s => Int -> Sized s a -> Bool
+lookup         :: S.Sequence s => Int -> Sized s a -> a
+lookupM        :: (S.Sequence s, Fail.MonadFail m) => Int -> Sized s a -> m a
+lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a
+update         :: S.Sequence s => Int -> a -> Sized s a -> Sized s a
+adjust         :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a
+mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b
+foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b
+foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b
+foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b
+foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b
+take           :: S.Sequence s => Int -> Sized s a -> Sized s a
+drop           :: S.Sequence s => Int -> Sized s a -> Sized s a
+splitAt        :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)
+subseq         :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a
+filter         :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a
+partition      :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)
+takeWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a
+dropWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a
+splitWhile     :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)
+zip            :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b)
+zip3           :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c)
+zipWith        :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c
+zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d
+unzip          :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b)
+unzip3         :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c)
+unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)
+unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)
+strict         :: S.Sequence s => Sized s a -> Sized s a
+strictWith     :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a
+structuralInvariant :: S.Sequence s => Sized s a -> Bool
+
+-- bonus functions, not in Sequence signature
+fromSeq        :: S.Sequence s => s a -> Sized s a
+toSeq          :: S.Sequence s => Sized s a -> s a
+
+
+
+moduleName = "Data.Edison.Seq.SizedSeq"
+instanceName (N _ s) = "SizedSeq(" ++ S.instanceName s ++ ")"
+
+data Sized s a = N !Int (s a)
+
+fromSeq xs = N (S.size xs) xs
+toSeq (N _ xs) = xs
+
+empty = N 0 S.empty
+singleton x = N 1 (S.singleton x)
+lcons x (N n xs) = N (n+1) (S.lcons x xs)
+rcons x (N n xs) = N (n+1) (S.rcons x xs)
+append (N m xs) (N n ys) = N (m+n) (S.append xs ys)
+
+lview (N n xs) = case S.lview xs of
+                   Nothing     -> fail "SizedSeq.lview: empty sequence"
+                   Just (x,xs) -> return (x, N (n-1) xs)
+
+lhead (N _ xs) = S.lhead xs
+
+lheadM (N _ xs) = S.lheadM xs
+
+ltail (N 0 _) = error "SizedSeq.ltail: empty sequence"
+ltail (N n xs) = N (n-1) (S.ltail xs)
+
+ltailM (N 0 _) = fail "SizedSeq.ltailM: empty sequence"
+ltailM (N n xs) = return (N (n-1) (S.ltail xs))
+
+rview (N n xs) = case S.rview xs of
+                   Nothing     -> fail "SizedSeq.rview: empty sequence"
+                   Just (x,xs) -> return (x, N (n-1) xs)
+
+rhead (N _ xs) = S.rhead xs
+
+rheadM (N _ xs) = S.rheadM xs
+
+rtail (N 0 _) = error "SizedSeq.rtail: empty sequence"
+rtail (N n xs) = N (n-1) (S.rtail xs)
+
+rtailM (N 0 _) = fail "SizedSeq.rtailM: empty sequence"
+rtailM (N n xs) = return (N (n-1) (S.rtail xs))
+
+null (N n _) = n == 0
+size (N n _) = n
+concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))
+reverse (N n xs) = N n (S.reverse xs)
+reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys)
+fromList = fromSeq . S.fromList
+toList (N _ xs) = S.toList xs
+map f (N n xs) = N n (S.map f xs)
+
+concatMap = concatMapUsingFoldr -- only function that uses a default
+
+fold  f e (N _ xs) = S.fold f e xs
+fold' f e (N _ xs) = S.fold' f e xs
+fold1 f  (N _ xs) = S.fold1 f xs
+fold1' f (N _ xs) = S.fold1' f xs
+foldr  f e (N _ xs) = S.foldr f e xs
+foldr' f e (N _ xs) = S.foldr' f e xs
+foldl  f e (N _ xs) = S.foldl f e xs
+foldl' f e (N _ xs) = S.foldl' f e xs
+foldr1  f (N _ xs) = S.foldr1 f xs
+foldr1' f (N _ xs) = S.foldr1' f xs
+foldl1  f (N _ xs) = S.foldl1 f xs
+foldl1' f (N _ xs) = S.foldl1' f xs
+reducer  f e (N _ xs) = S.reducer f e xs
+reducer' f e (N _ xs) = S.reducer' f e xs
+reducel  f e (N _ xs) = S.reducel f e xs
+reducel' f e (N _ xs) = S.reducel' f e xs
+reduce1  f (N _ xs) = S.reduce1 f xs
+reduce1' f (N _ xs) = S.reduce1' f xs
+
+copy n x
+    | n <= 0 = empty
+    | otherwise = N n (S.copy n x)
+
+inBounds i (N n _) = (i >= 0) && (i < n)
+lookup i (N _ xs) = S.lookup i xs
+lookupM i (N _ xs) = S.lookupM i xs
+lookupWithDefault d i (N _ xs) = S.lookupWithDefault d i xs
+update i x (N n xs) = N n (S.update i x xs)
+adjust f i (N n xs) = N n (S.adjust f i xs)
+mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs)
+foldrWithIndex  f e (N _ xs) = S.foldrWithIndex f e xs
+foldrWithIndex' f e (N _ xs) = S.foldrWithIndex' f e xs
+foldlWithIndex  f e (N _ xs) = S.foldlWithIndex f e xs
+foldlWithIndex' f e (N _ xs) = S.foldlWithIndex' f e xs
+
+take i original@(N n xs)
+  | i <= 0 = empty
+  | i >= n = original
+  | otherwise = N i (S.take i xs)
+
+drop i original@(N n xs)
+  | i <= 0 = original
+  | i >= n = empty
+  | otherwise = N (n-i) (S.drop i xs)
+
+splitAt i original@(N n xs)
+  | i <= 0 = (empty, original)
+  | i >= n = (original, empty)
+  | otherwise = let (ys,zs) = S.splitAt i xs
+                in (N i ys, N (n-i) zs)
+
+subseq i len original@(N n xs)
+  | i <= 0 = take len original
+  | i >= n || len <= 0 = empty
+  | i+len >= n = N (n-i) (S.drop i xs)
+  | otherwise = N len (S.subseq i len xs)
+
+filter p = fromSeq . S.filter p . toSeq
+
+partition p (N n xs) = (N m ys, N (n-m) zs)
+  where (ys,zs) = S.partition p xs
+        m = S.size ys
+
+takeWhile p = fromSeq . S.takeWhile p . toSeq
+dropWhile p = fromSeq . S.dropWhile p . toSeq
+
+splitWhile p (N n xs) = (N m ys, N (n-m) zs)
+  where (ys,zs) = S.splitWhile p xs
+        m = S.size ys
+
+zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys)
+zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs)
+
+zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys)
+zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs)
+
+unzip (N n xys) = (N n xs, N n ys)
+  where (xs,ys) = S.unzip xys
+
+unzip3 (N n xyzs) = (N n xs, N n ys, N n zs)
+  where (xs,ys,zs) = S.unzip3 xyzs
+
+unzipWith f g (N n xys) = (N n xs, N n ys)
+  where (xs,ys) = S.unzipWith f g xys
+
+unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs)
+  where (xs,ys,zs) = S.unzipWith3 f g h xyzs
+
+strict s@(N _ s') = S.strict s' `seq` s
+strictWith f s@(N _ s') = S.strictWith f s' `seq` s
+
+structuralInvariant (N i s) = i == S.size s
+
+-- instances
+
+instance S.Sequence s => S.Sequence (Sized s) where
+  {lcons = lcons; rcons = rcons;
+   lview = lview; lhead = lhead; ltail = ltail;
+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
+   rview = rview; rhead = rhead; rtail = rtail; null = null;
+   size = size; concat = concat; reverse = reverse;
+   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
+   reducer = reducer; reducer' = reducer'; reducel = reducel;
+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
+   copy = copy; inBounds = inBounds; lookup = lookup;
+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
+   filter = filter; partition = partition; takeWhile = takeWhile;
+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
+   strict = strict; strictWith = strictWith;
+   structuralInvariant = structuralInvariant; instanceName = instanceName}
+
+instance S.Sequence s => Functor (Sized s) where
+  fmap = map
+
+instance S.Sequence s => App.Alternative (Sized s) where
+  empty = empty
+  (<|>) = append
+
+instance S.Sequence s => App.Applicative (Sized s) where
+  pure = return
+  x <*> y = do
+     x' <- x
+     y' <- y
+     return (x' y')
+
+instance S.Sequence s => Monad (Sized s) where
+  return = singleton
+  xs >>= k = concatMap k xs
+
+instance S.Sequence s => MonadPlus (Sized s) where
+  mplus = append
+  mzero = empty
+
+
+instance Eq (s a) => Eq (Sized s a) where
+  (N m xs) == (N n ys) = (m == n) && (xs == ys)
+  -- this is probably identical to the code that would be
+  -- generated by "deriving (Eq)", but I wanted to be *sure*
+  -- that the sizes were compared before the inner sequences
+
+instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where
+  compare = defaultCompare
+
+instance (S.Sequence s, Show (s a)) => Show (Sized s a) where
+  showsPrec i xs rest
+    | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]
+    | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]
+
+instance (S.Sequence s, Read (s a)) => Read (Sized s a) where
+  readsPrec _ xs = maybeParens p xs
+      where p xs = tokenMatch (moduleName++".fromSeq") xs
+                     >>= readsPrec 10
+                     >>= \(l,rest) -> return (fromSeq l, rest)
+
+instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Sized s a) where
+  arbitrary = do xs <- arbitrary
+                 return (fromSeq xs)
+
+instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Sized s a) where
+  coarbitrary xs = coarbitrary (toSeq xs)
+
+
+instance S.Sequence s => Semigroup (Sized s a) where
+  (<>) = append
+instance S.Sequence s => Monoid (Sized s a) where
+  mempty  = empty
+  mappend = (SG.<>)