Add (Int, +) finger trees

containers-tests/tests/seq-properties.hs

@@ -12,7 +12,8 @@ import Data.Sequence.Internal
   , Digit (..)
   , node2
   , node3
-  , deep )
+  , deep
+  , unsafeMapNode )
 
 import Data.Sequence
 
@@ -242,7 +243,7 @@ instance (Sized a, Valid a) => Valid (FingerTree a) where
         s == size pr + size m + size sf && valid pr && valid m && valid sf
 
 instance (Sized a, Valid a) => Valid (Node a) where
-    valid node = size node == sum (fmap size node) && all valid node
+    valid node = size node == sum (unsafeMapNode size node) && all valid node
 
 instance Valid a => Valid (Digit a) where
     valid = all valid

containers/changelog.md

@@ -1,6 +1,20 @@
 # Changelog for [`containers` package](http://github.com/haskell/containers)
 
-## [0.6.4.1]
+## 0.6.5.1
+
+* Add support for finger trees with measurements in the `(Int, +)`
+  monoid.
+* Export more `Data.Sequence` internals.
+* Add a `Data.Sequence.StableInternal` module exporting functions
+  intended for use by external packages.
+* Remove the `Functor` and `Traversable` instances from the
+  heretofore "internal" `FingerTree` and `Node` types, in favor
+  of type-specific mapping functions. These instances could
+  break data structure invariants.
+* Remove the `Generic1 FingerTree` instance, which can no longer
+  be derived.
+
+## 0.6.4.1
 
 ### Bug fixes
 

containers/containers.cabal

@@ -41,6 +41,8 @@ Library
 
     exposed-modules:
         Data.Containers.ListUtils
+        Data.FingerTree.IntPlus
+        Data.FingerTree.IntPlus.Unsafe
         Data.IntMap
         Data.IntMap.Lazy
         Data.IntMap.Strict
@@ -65,6 +67,7 @@ Library
         Data.Sequence
         Data.Sequence.Internal
         Data.Sequence.Internal.Sorting
+        Data.Sequence.StableInternal
         Data.Tree
         Utils.Containers.Internal.BitUtil
         Utils.Containers.Internal.BitQueue

containers/src/Data/FingerTree/IntPlus.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE CPP #-}
+#include "containers.h"
+{-# LANGUAGE BangPatterns #-}
+
+#ifdef DEFINE_PATTERN_SYNONYMS
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+#endif
+
+-- | This module exports a type of finger trees with measurements ("sizes") in
+-- the @(Int, +)@ monoid. This type is used to implement sequences in
+-- "Data.Sequence". It may occasionally be useful for other purposes.
+--
+-- Caution: splitting and lookup functions assume that the size of the tree is
+-- at most @'maxBound' :: Int@. If this is not the case, then they may produce
+-- errors and/or utter nonsense.
+
+module Data.FingerTree.IntPlus
+  ( 
+#ifdef DEFINE_PATTERN_SYNONYMS
+    FingerTree (Empty, (:<|), (:|>), Singleton)
+#else
+    FingerTree
+#endif
+  , Elem (..)
+  , Sized (..)
+  , Split (..)
+  , UncheckedSplit (..)
+  , ViewL (..)
+  , ViewR (..)
+  , (<|)
+  , (|>)
+  , (><)
+  , fromList
+  , viewl
+  , viewr
+  , split
+  , uncheckedSplit
+  ) where
+
+import Data.Sequence.Internal
+  ( FingerTree (..), Sized (..), Elem (..) )
+import qualified Data.Sequence.Internal as S
+#if !MIN_VERSION_base(4,8,0)
+import Data.Word (Word)
+#endif
+
+infixr 5 ><
+infixr 5 <|, :<
+infixl 5 |>, :>
+
+(<|) :: Sized a => a -> FingerTree a -> FingerTree a
+(<|) = S.consTree
+
+(|>) :: Sized a => FingerTree a -> a -> FingerTree a
+(|>) = S.snocTree
+
+(><) :: Sized a => FingerTree a -> FingerTree a -> FingerTree a
+(><) = S.appendTree
+
+fromList :: Sized a => [a] -> FingerTree a
+fromList = S.fromListFT
+
+data ViewL a = a :< FingerTree a | EmptyL
+data ViewR a = FingerTree a :> a | EmptyR
+
+{-# INLINE viewl #-}
+viewl :: Sized a => FingerTree a -> ViewL a
+viewl t = case S.viewLTree t of
+  S.ConsLTree a as -> a :< as
+  S.EmptyLTree -> EmptyL
+
+{-# INLINE viewr #-}
+viewr :: Sized a => FingerTree a -> ViewR a
+viewr t = case S.viewRTree t of
+  S.SnocRTree as a -> as :> a
+  S.EmptyRTree -> EmptyR
+
+#ifdef DEFINE_PATTERN_SYNONYMS
+infixr 5 :<|
+infixl 5 :|>
+
+#if __GLASGOW_HASKELL__ >= 801
+{-# COMPLETE (:<|), Empty #-}
+{-# COMPLETE (:|>), Empty #-}
+#endif
+
+-- | A bidirectional pattern synonym matching an empty finger tree.
+pattern Empty :: S.FingerTree a
+pattern Empty = S.EmptyT
+
+-- | A bidirectional pattern synonym viewing the front of a non-empty
+-- finger tree.
+pattern (:<|) :: Sized a => a -> FingerTree a -> FingerTree a
+pattern x :<| xs <- (viewl -> x :< xs)
+  where
+    x :<| xs = x <| xs
+
+-- | A bidirectional pattern synonym viewing the rear of a non-empty
+-- finger tree.
+pattern (:|>) :: Sized a => FingerTree a -> a -> FingerTree a
+pattern xs :|> x <- (viewr -> xs :> x)
+  where
+    xs :|> x = xs |> x
+
+-- | A bidirectional pattern synonym for a singleton
+-- sequence. @Singleton xs@ is equivalent to @xs :< Empty@.
+pattern Singleton :: a -> FingerTree a
+pattern Singleton x <- S.Single x
+  where
+    Singleton = S.Single
+#endif
+
+data Split a
+  = Split !(FingerTree a) a !(FingerTree a)
+  | EmptySplit
+
+data UncheckedSplit a
+  = UncheckedSplit !(FingerTree a) a !(FingerTree a)
+
+-- | Split a finger tree around a measurement.
+--
+-- @split i xs = EmptySplit@ if and only if @xs = Empty@. Given that
+--
+-- @
+-- split i xs = 'Split' l x r
+-- @
+--
+-- it's guaranteed that
+--
+-- 1. @ xs = l <> (x <| r) @
+-- 2. @i >= size l@ or @l = Empty@
+-- 3. @i < size l + size x@ or @r = Empty@
+
+split :: Sized a => Int -> FingerTree a -> Split a
+split !_i S.EmptyT = EmptySplit
+split i ft
+  | S.Split l m r <- S.splitTree i ft
+  = Split l m r
+
+-- | Split a nonempty finger tree around a measurement. Given that
+--
+-- @
+-- uncheckedSplit i xs = 'UncheckedSplit' l x r
+-- @
+--
+-- it's guaranteed that
+--
+-- 1. @ xs = l <> (x <| r) @
+-- 2. @i >= size l@ or @l = Empty@
+-- 3. @i < size l + size x@ or @r = Empty@
+uncheckedSplit :: Sized a => Int -> FingerTree a -> UncheckedSplit a
+uncheckedSplit i ft
+  | S.Split l m r <- S.splitTree i ft
+  = UncheckedSplit l m r

containers/src/Data/FingerTree/IntPlus/Unsafe.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE CPP #-}
+#include "containers.h"
+
+-- | This module exports functions that can easily
+-- produce finger trees violating the annotation invariants.
+-- Trees violating these invariants will produce garbage
+-- when split.
+module Data.FingerTree.IntPlus.Unsafe
+  ( unsafeMap
+  , unsafeTraverse
+  ) where
+
+import Data.Sequence.Internal
+  ( FingerTree (..), Node (..) )
+import qualified Data.Sequence.Internal as S
+import Control.Applicative
+#if !MIN_VERSION_base(4,8,0)
+import Data.Traversable (traverse)
+#endif
+
+-- | Map over a 'FingerTree'. The following precondition
+-- is assumed but not checked:
+--
+-- For each @a@ in the @FingerTree@, @size (f a) = size a@.
+unsafeMap :: (a -> b) -> FingerTree a -> FingerTree b
+unsafeMap = S.unsafeMapFT
+
+-- | Traverse a 'FingerTree'. The following precondition is required
+-- but not checked:
+--
+-- For each element @a@ in the 'FingerTree',
+-- @size <$> f a = size a <$ f a@
+unsafeTraverse :: Applicative f => (a -> f b) -> FingerTree a -> f (FingerTree b)
+unsafeTraverse _ EmptyT = pure EmptyT
+unsafeTraverse f (Single x) = Single <$> f x
+unsafeTraverse f (Deep v pr m sf) =
+        liftA3 (Deep v) (traverse f pr) (unsafeTraverse (unsafeTraverseNode f) m) (traverse f sf)
+
+-- | Traverse a 'Node'. The following precondition is required
+-- but not checked:
+--
+-- For each element @a@ in the 'Node',
+-- @size <$> f a = size a <$ f a@
+unsafeTraverseNode :: Applicative f => (a -> f b) -> Node a -> f (Node b)
+unsafeTraverseNode f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)
+unsafeTraverseNode f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)