Skip to content

Commit 035e634

Browse files
treeowltreeowl
committed
Add (Int, +) finger trees
* Export a type for `(Int,+)` finger trees. * Export more `Data.Sequence` internals. * Offer a module of `Data.Sequence` internals intended for external use, that should obey the PVP.
1 parent 9f65489 commit 035e634

File tree

7 files changed

+369
-79
lines changed

7 files changed

+369
-79
lines changed

‎containers-tests/tests/seq-properties.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,8 @@ import Data.Sequence.Internal
1212
, Digit (..)
1313
, node2
1414
, node3
15-
, deep )
15+
, deep
16+
, unsafeMapNode )
1617

1718
import Data.Sequence
1819

@@ -242,7 +243,7 @@ instance (Sized a, Valid a) => Valid (FingerTree a) where
242243
s == size pr + size m + size sf && valid pr && valid m && valid sf
243244

244245
instance (Sized a, Valid a) => Valid (Node a) where
245-
valid node = size node == sum (fmap size node) && all valid node
246+
valid node = size node == sum (unsafeMapNode size node) && all valid node
246247

247248
instance Valid a => Valid (Digit a) where
248249
valid = all valid

‎containers/changelog.md

+15-1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,20 @@
11
# Changelog for [`containers` package](http://github.com/haskell/containers)
22

3-
## [0.6.4.1]
3+
## 0.6.5.1
4+
5+
* Add support for finger trees with measurements in the `(Int, +)`
6+
monoid.
7+
* Export more `Data.Sequence` internals.
8+
* Add a `Data.Sequence.StableInternal` module exporting functions
9+
intended for use by external packages.
10+
* Remove the `Functor` and `Traversable` instances from the
11+
heretofore "internal" `FingerTree` and `Node` types, in favor
12+
of type-specific mapping functions. These instances could
13+
break data structure invariants.
14+
* Remove the `Generic1 FingerTree` instance, which can no longer
15+
be derived.
16+
17+
## 0.6.4.1
418

519
### Bug fixes
620

‎containers/containers.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,8 @@ Library
4141

4242
exposed-modules:
4343
Data.Containers.ListUtils
44+
Data.FingerTree.IntPlus
45+
Data.FingerTree.IntPlus.Unsafe
4446
Data.IntMap
4547
Data.IntMap.Lazy
4648
Data.IntMap.Strict
@@ -65,6 +67,7 @@ Library
6567
Data.Sequence
6668
Data.Sequence.Internal
6769
Data.Sequence.Internal.Sorting
70+
Data.Sequence.StableInternal
6871
Data.Tree
6972
Utils.Containers.Internal.BitUtil
7073
Utils.Containers.Internal.BitQueue

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

+155
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
{-# LANGUAGE CPP #-}
2+
#include "containers.h"
3+
{-# LANGUAGE BangPatterns #-}
4+
5+
#ifdef DEFINE_PATTERN_SYNONYMS
6+
{-# LANGUAGE PatternSynonyms #-}
7+
{-# LANGUAGE ViewPatterns #-}
8+
#endif
9+
10+
-- | This module exports a type of finger trees with measurements ("sizes") in
11+
-- the @(Int, +)@ monoid. This type is used to implement sequences in
12+
-- "Data.Sequence". It may occasionally be useful for other purposes.
13+
--
14+
-- Caution: splitting and lookup functions assume that the size of the tree is
15+
-- at most @'maxBound' :: Int@. If this is not the case, then they may produce
16+
-- errors and/or utter nonsense.
17+
18+
module Data.FingerTree.IntPlus
19+
(
20+
#ifdef DEFINE_PATTERN_SYNONYMS
21+
FingerTree (Empty, (:<|), (:|>), Singleton)
22+
#else
23+
FingerTree
24+
#endif
25+
, Elem (..)
26+
, Sized (..)
27+
, Split (..)
28+
, UncheckedSplit (..)
29+
, ViewL (..)
30+
, ViewR (..)
31+
, (<|)
32+
, (|>)
33+
, (><)
34+
, fromList
35+
, viewl
36+
, viewr
37+
, split
38+
, uncheckedSplit
39+
) where
40+
41+
import Data.Sequence.Internal
42+
( FingerTree (..), Sized (..), Elem (..) )
43+
import qualified Data.Sequence.Internal as S
44+
#if !MIN_VERSION_base(4,8,0)
45+
import Data.Word (Word)
46+
#endif
47+
48+
infixr 5 ><
49+
infixr 5 <|, :<
50+
infixl 5 |>, :>
51+
52+
(<|) :: Sized a => a -> FingerTree a -> FingerTree a
53+
(<|) = S.consTree
54+
55+
(|>) :: Sized a => FingerTree a -> a -> FingerTree a
56+
(|>) = S.snocTree
57+
58+
(><) :: Sized a => FingerTree a -> FingerTree a -> FingerTree a
59+
(><) = S.appendTree
60+
61+
fromList :: Sized a => [a] -> FingerTree a
62+
fromList = S.fromListFT
63+
64+
data ViewL a = a :< FingerTree a | EmptyL
65+
data ViewR a = FingerTree a :> a | EmptyR
66+
67+
{-# INLINE viewl #-}
68+
viewl :: Sized a => FingerTree a -> ViewL a
69+
viewl t = case S.viewLTree t of
70+
S.ConsLTree a as -> a :< as
71+
S.EmptyLTree -> EmptyL
72+
73+
{-# INLINE viewr #-}
74+
viewr :: Sized a => FingerTree a -> ViewR a
75+
viewr t = case S.viewRTree t of
76+
S.SnocRTree as a -> as :> a
77+
S.EmptyRTree -> EmptyR
78+
79+
#ifdef DEFINE_PATTERN_SYNONYMS
80+
infixr 5 :<|
81+
infixl 5 :|>
82+
83+
#if __GLASGOW_HASKELL__ >= 801
84+
{-# COMPLETE (:<|), Empty #-}
85+
{-# COMPLETE (:|>), Empty #-}
86+
#endif
87+
88+
-- | A bidirectional pattern synonym matching an empty finger tree.
89+
pattern Empty :: S.FingerTree a
90+
pattern Empty = S.EmptyT
91+
92+
-- | A bidirectional pattern synonym viewing the front of a non-empty
93+
-- finger tree.
94+
pattern (:<|) :: Sized a => a -> FingerTree a -> FingerTree a
95+
pattern x :<| xs <- (viewl -> x :< xs)
96+
where
97+
x :<| xs = x <| xs
98+
99+
-- | A bidirectional pattern synonym viewing the rear of a non-empty
100+
-- finger tree.
101+
pattern (:|>) :: Sized a => FingerTree a -> a -> FingerTree a
102+
pattern xs :|> x <- (viewr -> xs :> x)
103+
where
104+
xs :|> x = xs |> x
105+
106+
-- | A bidirectional pattern synonym for a singleton
107+
-- sequence. @Singleton xs@ is equivalent to @xs :< Empty@.
108+
pattern Singleton :: a -> FingerTree a
109+
pattern Singleton x <- S.Single x
110+
where
111+
Singleton = S.Single
112+
#endif
113+
114+
data Split a
115+
= Split !(FingerTree a) a !(FingerTree a)
116+
| EmptySplit
117+
118+
data UncheckedSplit a
119+
= UncheckedSplit !(FingerTree a) a !(FingerTree a)
120+
121+
-- | Split a finger tree around a measurement.
122+
--
123+
-- @split i xs = EmptySplit@ if and only if @xs = Empty@. Given that
124+
--
125+
-- @
126+
-- split i xs = 'Split' l x r
127+
-- @
128+
--
129+
-- it's guaranteed that
130+
--
131+
-- 1. @ xs = l <> (x <| r) @
132+
-- 2. @i >= size l@ or @l = Empty@
133+
-- 3. @i < size l + size x@ or @r = Empty@
134+
135+
split :: Sized a => Int -> FingerTree a -> Split a
136+
split !_i S.EmptyT = EmptySplit
137+
split i ft
138+
| S.Split l m r <- S.splitTree i ft
139+
= Split l m r
140+
141+
-- | Split a nonempty finger tree around a measurement. Given that
142+
--
143+
-- @
144+
-- uncheckedSplit i xs = 'UncheckedSplit' l x r
145+
-- @
146+
--
147+
-- it's guaranteed that
148+
--
149+
-- 1. @ xs = l <> (x <| r) @
150+
-- 2. @i >= size l@ or @l = Empty@
151+
-- 3. @i < size l + size x@ or @r = Empty@
152+
uncheckedSplit :: Sized a => Int -> FingerTree a -> UncheckedSplit a
153+
uncheckedSplit i ft
154+
| S.Split l m r <- S.splitTree i ft
155+
= UncheckedSplit l m r

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

+46
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
{-# LANGUAGE CPP #-}
2+
#include "containers.h"
3+
4+
-- | This module exports functions that can easily
5+
-- produce finger trees violating the annotation invariants.
6+
-- Trees violating these invariants will produce garbage
7+
-- when split.
8+
module Data.FingerTree.IntPlus.Unsafe
9+
( unsafeMap
10+
, unsafeTraverse
11+
) where
12+
13+
import Data.Sequence.Internal
14+
( FingerTree (..), Node (..) )
15+
import qualified Data.Sequence.Internal as S
16+
import Control.Applicative
17+
#if !MIN_VERSION_base(4,8,0)
18+
import Data.Traversable (traverse)
19+
#endif
20+
21+
-- | Map over a 'FingerTree'. The following precondition
22+
-- is assumed but not checked:
23+
--
24+
-- For each @a@ in the @FingerTree@, @size (f a) = size a@.
25+
unsafeMap :: (a -> b) -> FingerTree a -> FingerTree b
26+
unsafeMap = S.unsafeMapFT
27+
28+
-- | Traverse a 'FingerTree'. The following precondition is required
29+
-- but not checked:
30+
--
31+
-- For each element @a@ in the 'FingerTree',
32+
-- @size <$> f a = size a <$ f a@
33+
unsafeTraverse :: Applicative f => (a -> f b) -> FingerTree a -> f (FingerTree b)
34+
unsafeTraverse _ EmptyT = pure EmptyT
35+
unsafeTraverse f (Single x) = Single <$> f x
36+
unsafeTraverse f (Deep v pr m sf) =
37+
liftA3 (Deep v) (traverse f pr) (unsafeTraverse (unsafeTraverseNode f) m) (traverse f sf)
38+
39+
-- | Traverse a 'Node'. The following precondition is required
40+
-- but not checked:
41+
--
42+
-- For each element @a@ in the 'Node',
43+
-- @size <$> f a = size a <$ f a@
44+
unsafeTraverseNode :: Applicative f => (a -> f b) -> Node a -> f (Node b)
45+
unsafeTraverseNode f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)
46+
unsafeTraverseNode f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)

0 commit comments

Comments
 (0)