# Ticket #3271: new-methods-for-data_sequence.3.dpatch

File new-methods-for-data_sequence.3.dpatch, 46.9 KB (added by LouisWasserman, 7 years ago) |
---|

Line | |
---|---|

1 | Thu Jul 16 20:04:53 EDT 2009 wasserman.louis@gmail.com |

2 | * Ticket #3271: New methods for Data.Sequence |

3 | |

4 | New patches: |

5 | |

6 | [Ticket #3271: New methods for Data.Sequence |

7 | wasserman.louis@gmail.com**20090717000453 |

8 | Ignore-this: 2afb31c5ec1ae0fa48bc5e191082a128 |

9 | ] { |

10 | hunk ./Data/Sequence.hs 39 |

11 | -- * Construction |

12 | empty, -- :: Seq a |

13 | singleton, -- :: a -> Seq a |

14 | + replicate, -- :: Int -> a -> Seq a |

15 | (<|), -- :: a -> Seq a -> Seq a |

16 | (|>), -- :: Seq a -> a -> Seq a |

17 | (><), -- :: Seq a -> Seq a -> Seq a |

18 | hunk ./Data/Sequence.hs 44 |

19 | fromList, -- :: [a] -> Seq a |

20 | + -- ** Sequential construction |

21 | + iterateN, -- :: Int -> (a -> a) -> a -> Seq a |

22 | + unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a |

23 | -- * Deconstruction |

24 | -- | Additional functions for deconstructing sequences are available |

25 | -- via the 'Foldable' instance of 'Seq'. |

26 | hunk ./Data/Sequence.hs 59 |

27 | viewl, -- :: Seq a -> ViewL a |

28 | ViewR(..), |

29 | viewr, -- :: Seq a -> ViewR a |

30 | + -- ** Scanning |

31 | + scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a |

32 | + scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a |

33 | + scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b |

34 | + scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a |

35 | + -- ** Sublists |

36 | + tails, -- :: Seq a -> Seq (Seq a) |

37 | + inits, -- :: Seq a -> Seq (Seq a) |

38 | + takeWhile, -- :: (a -> Bool) -> Seq a -> Seq a |

39 | + dropWhile, -- :: (a -> Bool) -> Seq a -> Seq a |

40 | + span, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

41 | + break, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

42 | + partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

43 | + filter, -- :: (a -> Bool) -> Seq a -> Seq a |

44 | + -- ** Sorts |

45 | + sort, -- :: Ord a => Seq a -> Seq a |

46 | + sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a |

47 | -- ** Indexing |

48 | index, -- :: Seq a -> Int -> a |

49 | adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a |

50 | hunk ./Data/Sequence.hs 85 |

51 | splitAt, -- :: Int -> Seq a -> (Seq a, Seq a) |

52 | -- * Transformations |

53 | reverse, -- :: Seq a -> Seq a |

54 | + -- ** Zips |

55 | + zip, -- :: Seq a -> Seq b -> Seq (a, b) |

56 | + zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c |

57 | + zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c) |

58 | + zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d |

59 | + zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d) |

60 | + zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e |

61 | #if TESTING |

62 | valid, |

63 | #endif |

64 | hunk ./Data/Sequence.hs 98 |

65 | ) where |

66 | |

67 | import Prelude hiding ( |

68 | - null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, |

69 | - reverse) |

70 | -import qualified Data.List (foldl') |

71 | -import Control.Applicative (Applicative(..), (<$>)) |

72 | + null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, span, |

73 | + scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3, |

74 | + takeWhile, dropWhile, break, iterate, reverse, filter) |

75 | +import qualified Data.List (foldl', zipWith) |

76 | +import Control.Applicative (Applicative(..), (<$>), liftA, liftA2, liftA3) |

77 | import Control.Monad (MonadPlus(..)) |

78 | import Data.Monoid (Monoid(..)) |

79 | import Data.Foldable |

80 | hunk ./Data/Sequence.hs 120 |

81 | #endif |

82 | |

83 | #if TESTING |

84 | -import Control.Monad (liftM, liftM3, liftM4) |

85 | -import Test.QuickCheck |

86 | +import Control.Monad (liftM, liftM2, liftM3, liftM4) |

87 | +import Test.QuickCheck hiding ((><)) |

88 | #endif |

89 | |

90 | infixr 5 `consTree` |

91 | hunk ./Data/Sequence.hs 126 |

92 | infixl 5 `snocTree` |

93 | +infixr 5 `consDigitToTree` |

94 | +infixl 6 `snocDigitToTree` |

95 | |

96 | infixr 5 >< |

97 | infixr 5 <|, :< |

98 | hunk ./Data/Sequence.hs 280 |

99 | traverse f sf |

100 | |

101 | {-# INLINE deep #-} |

102 | -{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

103 | -{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

104 | +{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

105 | +{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

106 | deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a |

107 | deep pr m sf = Deep (size pr + size m + size sf) pr m sf |

108 | |

109 | hunk ./Data/Sequence.hs 318 |

110 | foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d |

111 | |

112 | instance Functor Digit where |

113 | - fmap = fmapDefault |

114 | + fmap f (One x) = One (f x) |

115 | + fmap f (Two x y) = Two (f x) (f y) |

116 | + fmap f (Three x y z) = Three (f x) (f y) (f z) |

117 | + fmap f (Four x y z w) = Four (f x) (f y) (f z) (f w) |

118 | |

119 | instance Traversable Digit where |

120 | hunk ./Data/Sequence.hs 324 |

121 | + {-# INLINE traverse #-} |

122 | traverse f (One a) = One <$> f a |

123 | traverse f (Two a b) = Two <$> f a <*> f b |

124 | traverse f (Three a b c) = Three <$> f a <*> f b <*> f c |

125 | hunk ./Data/Sequence.hs 331 |

126 | traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d |

127 | |

128 | instance Sized a => Sized (Digit a) where |

129 | - {-# SPECIALIZE instance Sized (Digit (Elem a)) #-} |

130 | - {-# SPECIALIZE instance Sized (Digit (Node a)) #-} |

131 | - size xs = foldl (\ i x -> i + size x) 0 xs |

132 | + size = sizeDigit |

133 | + |

134 | +{-# SPECIALIZE sizeDigit :: Digit (Elem a) -> Int #-} |

135 | +{-# SPECIALIZE sizeDigit :: Digit (Node a) -> Int #-} |

136 | +sizeDigit :: Sized a => Digit a -> Int |

137 | +sizeDigit (One x) = size x |

138 | +sizeDigit (Two x y) = size x + size y |

139 | +sizeDigit (Three x y z) = size x + size y + size z |

140 | +sizeDigit (Four x y z w) = size x + size y + size z + size w |

141 | |

142 | {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-} |

143 | {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-} |

144 | hunk ./Data/Sequence.hs 366 |

145 | foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c |

146 | |

147 | instance Functor Node where |

148 | - fmap = fmapDefault |

149 | + fmap f (Node2 n a b) = Node2 n (f a) (f b) |

150 | + fmap f (Node3 n a b c) = Node3 n (f a) (f b) (f c) |

151 | |

152 | instance Traversable Node where |

153 | traverse f (Node2 v a b) = Node2 v <$> f a <*> f b |

154 | hunk ./Data/Sequence.hs 415 |

155 | showsPrec p (Elem x) = showsPrec p x |

156 | #endif |

157 | |

158 | +-- Applicative construction |

159 | + |

160 | +newtype Id a = Id {runId :: a} |

161 | + |

162 | +instance Functor Id where |

163 | + fmap f (Id x) = Id (f x) |

164 | + |

165 | +instance Applicative Id where |

166 | + pure = Id |

167 | + m <*> k = Id (runId m (runId k)) |

168 | + |

169 | +newtype State s a = State {runState :: s -> (s, a)} |

170 | + |

171 | +instance Functor (State s) where |

172 | + fmap = liftA |

173 | + |

174 | +instance Applicative (State s) where |

175 | + pure x = State $ \ s -> (s, x) |

176 | + m <*> k = State $ \ s -> case runState m s of |

177 | + (s', f) -> case runState k s' of |

178 | + (s'', x) -> (s'', f x) |

179 | + |

180 | +execState :: State s a -> s -> a |

181 | +execState m x = snd (runState m x) |

182 | + |

183 | +-- | 'applicativeTree' takes an Applicative-wrapped construction of a piece of a FingerTree, assumed |

184 | +-- to always have the same size (which is put in the second argument), and replicates it as many times |

185 | +-- as specified. This encapsulates the behavior of several procedures, most notably iterate and replicate. |

186 | + |

187 | +{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-} |

188 | +{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-} |

189 | + -- Special note: the Id specialization automatically does node sharing, reducing memory usage of the |

190 | + -- resulting tree to /O(log n)/. |

191 | +applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a) |

192 | +applicativeTree n mSize m = mSize `seq` case n of |

193 | + 0 -> pure Empty |

194 | + 1 -> liftA Single m |

195 | + 2 -> deepA one empty one |

196 | + 3 -> deepA two empty one |

197 | + 4 -> deepA two empty two |

198 | + 5 -> deepA three empty two |

199 | + 6 -> deepA three empty three |

200 | + 7 -> deepA four empty three |

201 | + 8 -> deepA four empty four |

202 | + _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of |

203 | + 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three |

204 | + 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three |

205 | + _ -> deepA four (applicativeTree (q - 2) mSize' n3) four |

206 | + where one = liftA One m |

207 | + two = liftA2 Two m m |

208 | + three = liftA3 Three m m m |

209 | + four = liftA3 Four m m m <*> m |

210 | + deepA = liftA3 (Deep (n * mSize)) |

211 | + mSize' = 3 * mSize |

212 | + n3 = liftA3 (Node3 mSize') m m m |

213 | + empty = pure Empty |

214 | + |

215 | ------------------------------------------------------------------------ |

216 | -- Construction |

217 | ------------------------------------------------------------------------ |

218 | hunk ./Data/Sequence.hs 484 |

219 | singleton :: a -> Seq a |

220 | singleton x = Seq (Single (Elem x)) |

221 | |

222 | +-- | /O(log n)/. @replicate n x@ is a sequence of length @n@ with @x@ the value of every element. |

223 | +replicate :: Int -> a -> Seq a |

224 | +replicate n x = Seq (runId (applicativeTree n 1 (Id (Elem x)))) |

225 | + |

226 | -- | /O(1)/. Add an element to the left end of a sequence. |

227 | -- Mnemonic: a triangle with the single element at the pointy end. |

228 | (<|) :: a -> Seq a -> Seq a |

229 | hunk ./Data/Sequence.hs 584 |

230 | appendTree1 xs a Empty = |

231 | xs `snocTree` a |

232 | appendTree1 (Single x) a xs = |

233 | - x `consTree` a `consTree` xs |

234 | + Two x a `consDigitToTree` xs |

235 | appendTree1 xs a (Single x) = |

236 | hunk ./Data/Sequence.hs 586 |

237 | - xs `snocTree` a `snocTree` x |

238 | + xs `snocDigitToTree` Two a x |

239 | appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) = |

240 | Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 |

241 | |

242 | hunk ./Data/Sequence.hs 626 |

243 | |

244 | appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

245 | appendTree2 Empty a b xs = |

246 | - a `consTree` b `consTree` xs |

247 | + Two a b `consDigitToTree` xs |

248 | appendTree2 xs a b Empty = |

249 | hunk ./Data/Sequence.hs 628 |

250 | - xs `snocTree` a `snocTree` b |

251 | + xs `snocDigitToTree` Two a b |

252 | appendTree2 (Single x) a b xs = |

253 | hunk ./Data/Sequence.hs 630 |

254 | - x `consTree` a `consTree` b `consTree` xs |

255 | + Three x a b `consDigitToTree` xs |

256 | appendTree2 xs a b (Single x) = |

257 | hunk ./Data/Sequence.hs 632 |

258 | - xs `snocTree` a `snocTree` b `snocTree` x |

259 | + xs `snocDigitToTree` Three a b x |

260 | appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) = |

261 | Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 |

262 | |

263 | hunk ./Data/Sequence.hs 672 |

264 | |

265 | appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

266 | appendTree3 Empty a b c xs = |

267 | - a `consTree` b `consTree` c `consTree` xs |

268 | + Three a b c `consDigitToTree` xs |

269 | appendTree3 xs a b c Empty = |

270 | hunk ./Data/Sequence.hs 674 |

271 | - xs `snocTree` a `snocTree` b `snocTree` c |

272 | + xs `snocDigitToTree` Three a b c |

273 | appendTree3 (Single x) a b c xs = |

274 | hunk ./Data/Sequence.hs 676 |

275 | - x `consTree` a `consTree` b `consTree` c `consTree` xs |

276 | + Four x a b c `consDigitToTree` xs |

277 | appendTree3 xs a b c (Single x) = |

278 | hunk ./Data/Sequence.hs 678 |

279 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x |

280 | + xs `snocDigitToTree` Four a b c x |

281 | appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) = |

282 | Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 |

283 | |

284 | hunk ./Data/Sequence.hs 718 |

285 | |

286 | appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a) |

287 | appendTree4 Empty a b c d xs = |

288 | - a `consTree` b `consTree` c `consTree` d `consTree` xs |

289 | + Four a b c d `consDigitToTree` xs |

290 | appendTree4 xs a b c d Empty = |

291 | hunk ./Data/Sequence.hs 720 |

292 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d |

293 | + xs `snocDigitToTree` Four a b c d |

294 | appendTree4 (Single x) a b c d xs = |

295 | hunk ./Data/Sequence.hs 722 |

296 | - x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs |

297 | + x `consTree` Four a b c d `consDigitToTree` xs |

298 | appendTree4 xs a b c d (Single x) = |

299 | hunk ./Data/Sequence.hs 724 |

300 | - xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x |

301 | + xs `snocDigitToTree` Four a b c d `snocTree` x |

302 | appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) = |

303 | Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 |

304 | |

305 | hunk ./Data/Sequence.hs 762 |

306 | addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = |

307 | appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 |

308 | |

309 | +-- Cons and snoc for entire digits at once. This code was automatically generated. |

310 | +-- |

311 | +-- For general internal use, this is *considerably more efficient* than repeated use of |

312 | +-- consTree or snocTree, which end up case'ing the appropriate digit once for every |

313 | +-- insertion, while this code only does it once. |

314 | + |

315 | +{-# SPECIALIZE consDigitToTree :: Digit (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-} |

316 | +{-# SPECIALIZE consDigitToTree :: Digit (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-} |

317 | +consDigitToTree :: Sized a => Digit a -> FingerTree a -> FingerTree a |

318 | +consDigitToTree dig Empty |

319 | + = digitToTree dig |

320 | +consDigitToTree dig (Single a) |

321 | + = Deep (size dig + size a) dig Empty (One a) |

322 | +consDigitToTree dig@(One a) (Deep n (One x) m sf) |

323 | + = Deep (n + size dig) (Two a x) m sf |

324 | +consDigitToTree dig@(One a) (Deep n (Two x y) m sf) |

325 | + = Deep (n + size dig) (Three a x y) m sf |

326 | +consDigitToTree dig@(One a) (Deep n (Three x y z) m sf) |

327 | + = Deep (n + size dig) (Four a x y z) m sf |

328 | +consDigitToTree dig@(One a) (Deep n (Four x y z w) m sf) |

329 | + = Deep (n + size dig) (Two a x) ((node3 y z w) `consTree` m) sf |

330 | +consDigitToTree dig@(Two a b) (Deep n (One x) m sf) |

331 | + = Deep (n + size dig) (Three a b x) m sf |

332 | +consDigitToTree dig@(Two a b) (Deep n (Two x y) m sf) |

333 | + = Deep (n + size dig) (Four a b x y) m sf |

334 | +consDigitToTree dig@(Two a b) (Deep n (Three x y z) m sf) |

335 | + = Deep (n + size dig) (Two a b) ((node3 x y z) `consTree` m) sf |

336 | +consDigitToTree dig@(Two a b) (Deep n (Four x y z w) m sf) |

337 | + = Deep (n + size dig) (Three a b x) ((node3 y z w) `consTree` m) sf |

338 | +consDigitToTree dig@(Three a b c) (Deep n (One x) m sf) |

339 | + = Deep (n + size dig) (Four a b c x) m sf |

340 | +consDigitToTree dig@(Three a b c) (Deep n (Two x y) m sf) |

341 | + = Deep (n + size dig) (Two a b) ((node3 c x y) `consTree` m) sf |

342 | +consDigitToTree dig@(Three a b c) (Deep n (Three x y z) m sf) |

343 | + = Deep (n + size dig) (Three a b c) ((node3 x y z) `consTree` m) sf |

344 | +consDigitToTree dig@(Three a b c) (Deep n (Four x y z w) m sf) |

345 | + = Deep (n + size dig) (One a) (Two (node3 b c x) (node3 y z w) `consDigitToTree` m) sf |

346 | +consDigitToTree dig@(Four a b c d) (Deep n (One x) m sf) |

347 | + = Deep (n + size dig) (Two a b) ((node3 c d x) `consTree` m) sf |

348 | +consDigitToTree dig@(Four a b c d) (Deep n (Two x y) m sf) |

349 | + = Deep (n + size dig) (Three a b c) ((node3 d x y) `consTree` m) sf |

350 | +consDigitToTree dig@(Four a b c d) (Deep n (Three x y z) m sf) |

351 | + = Deep (n + size dig) (One a) (Two (node3 b c d) (node3 x y z) `consDigitToTree` m) sf |

352 | +consDigitToTree dig@(Four a b c d) (Deep n (Four x y z w) m sf) |

353 | + = Deep (n + size dig) (Two a b) (Two (node3 c d x) (node3 y z w) `consDigitToTree` m) sf |

354 | + |

355 | +{-# SPECIALIZE snocDigitToTree :: FingerTree (Elem a) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

356 | +{-# SPECIALIZE snocDigitToTree :: FingerTree (Node a) -> Digit (Node a) -> FingerTree (Node a) #-} |

357 | +snocDigitToTree :: Sized a => FingerTree a -> Digit a -> FingerTree a |

358 | +snocDigitToTree Empty dig |

359 | + = digitToTree dig |

360 | +snocDigitToTree (Single a) dig |

361 | + = Deep (size a + size dig) (One a) Empty dig |

362 | +snocDigitToTree (Deep n pr m (One a)) dig@(One x) |

363 | + = Deep (n + size dig) pr m (Two a x) |

364 | +snocDigitToTree (Deep n pr m (One a)) dig@(Two x y) |

365 | + = Deep (n + size dig) pr m (Three a x y) |

366 | +snocDigitToTree (Deep n pr m (One a)) dig@(Three x y z) |

367 | + = Deep (n + size dig) pr m (Four a x y z) |

368 | +snocDigitToTree (Deep n pr m (One a)) dig@(Four x y z w) |

369 | + = Deep (n + size dig) pr (m `snocTree` (node3 a x y)) (Two z w) |

370 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(One x) |

371 | + = Deep (n + size dig) pr m (Three a b x) |

372 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Two x y) |

373 | + = Deep (n + size dig) pr m (Four a b x y) |

374 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Three x y z) |

375 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Two y z) |

376 | +snocDigitToTree (Deep n pr m (Two a b)) dig@(Four x y z w) |

377 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Three y z w) |

378 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(One x) |

379 | + = Deep (n + size dig) pr m (Four a b c x) |

380 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Two x y) |

381 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two x y) |

382 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Three x y z) |

383 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three x y z) |

384 | +snocDigitToTree (Deep n pr m (Three a b c)) dig@(Four x y z w) |

385 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 x y z)) (One w) |

386 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(One x) |

387 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two d x) |

388 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Two x y) |

389 | + = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three d x y) |

390 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Three x y z) |

391 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (One z) |

392 | +snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Four x y z w) |

393 | + = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (Two z w) |

394 | + |

395 | +-- | Builds a sequence from a seed value. Takes time linear in the number of generated elements. /WARNING: If the number of generated elements is infinite, this method will not terminate./ |

396 | +unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a |

397 | +unfoldr f b = unfoldr' empty b where |

398 | + -- uses tail recursion rather than, for instance, the List implementation. |

399 | + unfoldr' as b = case f b of |

400 | + Nothing -> as |

401 | + Just (a, b') -> unfoldr' (as |> a) b' |

402 | + |

403 | +-- | /O(n)/. Constructs a sequence by repeated application of a function to a seed value. |

404 | +-- |

405 | +-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x)) |

406 | +iterateN :: Int -> (a -> a) -> a -> Seq a |

407 | +-- borrows the structure of the sequence from replicate and preserves it with mapAccumL |

408 | +iterateN n f x = n `seq` Seq (execState (applicativeTree n 1 run) x) |

409 | + where run = State $ \ x -> (f x, Elem x) |

410 | + |

411 | + |

412 | ------------------------------------------------------------------------ |

413 | -- Deconstruction |

414 | ------------------------------------------------------------------------ |

415 | hunk ./Data/Sequence.hs 999 |

416 | viewRTree (Deep s pr m (Four w x y z)) = |

417 | Just2 (Deep (s - size z) pr m (Three w x y)) z |

418 | |

419 | +------------------------------------------------------------------------ |

420 | +-- Scans |

421 | +-- |

422 | +-- These are not particularly complex applications of the Traversable |

423 | +-- functor, though making the correspondence with Data.List exact |

424 | +-- requires the use of (<|) and (|>). |

425 | +-- |

426 | +-- Note that save for the single (<|) or (|>), we maintain the original |

427 | +-- structure of the Seq, not having to do any restructuring of our own. |

428 | +-- |

429 | +-- wasserman.louis@gmail.com, 5/23/09 |

430 | +------------------------------------------------------------------------ |

431 | + |

432 | +-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced values from the left: |

433 | +-- |

434 | +-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...] |

435 | +scanl :: (a -> b -> a) -> a -> Seq b -> Seq a |

436 | +scanl f z0 xs = z0 <| snd (mapAccumL accum z0 xs) |

437 | + where accum x z = let x' = f x z in (x', x') |

438 | + |

439 | +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: |

440 | +-- |

441 | +-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...] |

442 | +scanl1 :: (a -> a -> a) -> Seq a -> Seq a |

443 | +scanl1 f xs = case viewl xs of |

444 | + EmptyL -> error "scanl1 takes a nonempty sequence as an argument" |

445 | + x :< xs' -> scanl f x xs' |

446 | + |

447 | +-- | 'scanr' is the right-to-left dual of 'scanl'. |

448 | +scanr :: (a -> b -> b) -> b -> Seq a -> Seq b |

449 | +scanr f z0 xs = snd (mapAccumR accum z0 xs) |> z0 |

450 | + where accum z x = let z' = f x z in (z', z') |

451 | + |

452 | +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. |

453 | +scanr1 :: (a -> a -> a) -> Seq a -> Seq a |

454 | +scanr1 f xs = case viewr xs of |

455 | + EmptyR -> error "scanr1 takes a nonempty sequence as an argument" |

456 | + xs' :> x -> scanr f x xs' |

457 | + |

458 | -- Indexing |

459 | |

460 | -- | /O(log(min(i,n-i)))/. The element at the specified position, |

461 | hunk ./Data/Sequence.hs 1188 |

462 | splitAt i (Seq xs) = (Seq l, Seq r) |

463 | where (l, r) = split i xs |

464 | |

465 | +-- | /O(n)/. Returns a sequence of all suffixes of this sequence, longest first. For example, |

466 | +-- |

467 | +-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""] |

468 | +-- |

469 | +-- Evaluating the /i/th tail takes /O(log(min(i, n-i)))/, but evaluating every tail in the sequence |

470 | +-- takes /O(n)/ due to sharing. |

471 | +tails :: Seq a -> Seq (Seq a) |

472 | +tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty |

473 | +{- |

474 | +tails xs = iterateN (length xs + 1) tail' xs where |

475 | + tail' ys _ = case viewl ys of |

476 | + _ :< ys' -> ys' |

477 | + _ -> error "Invariant failure in Data.Sequence.tails" -- should never happen |

478 | +-} |

479 | + |

480 | +-- | /O(n)/. Returns a sequence of all prefixes of this sequence, shortest first. For example, |

481 | +-- |

482 | +-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"] |

483 | +-- |

484 | +-- Evaluating the /i/th init takes /O(log(min(i, n-i)))/, but evaluating every init in the sequence |

485 | +-- takes /O(n)/ due to sharing. |

486 | +inits :: Seq a -> Seq (Seq a) |

487 | +inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs) |

488 | +-- inits = scanl (|>) empty |

489 | + |

490 | +-- This implementation of tails (and, analogously, inits) has the following algorithmic advantages: |

491 | +-- Evaluating each tail in the sequence takes linear total time, which is better than we could say for |

492 | +-- @fromList [drop n xs | n <- [0..length xs]]@. |

493 | +-- Evaluating any individual tail takes logarithmic time, which is better than we can say for either |

494 | +-- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@. |

495 | +-- |

496 | +-- Moreover, if we actually look at every tail in the sequence, the following benchmarks demonstrate that |

497 | +-- this implementation is actually slightly faster than any of the above: |

498 | +-- |

499 | +-- Times (ms) min mean +/-sd median max |

500 | +-- Seq.tails: 16.875 20.405 4.247 19.663 47.972 |

501 | +-- scanr: 68.429 76.948 6.505 75.264 99.650 |

502 | +-- iterateN: 17.571 22.231 1.031 22.251 23.917 |

503 | +-- |

504 | +-- The algorithm for tails (and, analogously, inits) is as follows: |

505 | +-- |

506 | +-- A Node in the FingerTree of tails is constructed by evaluating the corresponding tail of the FingerTree |

507 | +-- of Nodes, considering the first Node in this tail, and constructing a Node in which each tail of this |

508 | +-- Node is made to be the prefix of the remaining tree. This ends up working quite elegantly, as the remainder of |

509 | +-- the tail of the FingerTree of Nodes becomes the middle of a new tail, the suffix of the Node is the |

510 | +-- prefix, and the suffix of the original tree is retained. |

511 | +-- |

512 | +-- In particular, evaluating the /i/th tail involves making as many partial evaluations as the Node depth of |

513 | +-- the /i/th element. In addition, when we evaluate the /i/th tail, and we also evaluate the /j/th tail, |

514 | +-- and /m/ Nodes are on the path to both /i/ and /j/, each of those /m/ evaluations are shared between |

515 | +-- the computation of the /i/th and /j/th tails. |

516 | +-- |

517 | +-- wasserman.louis@gmail.com, 7/16/09 |

518 | + |

519 | +-- | Given the size of a digit and the digit itself, efficiently converts it to a FingerTree. |

520 | +digitToTree' :: Int -> Digit a -> FingerTree a |

521 | +digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d) |

522 | +digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c) |

523 | +digitToTree' n (Two a b) = Deep n (One a) Empty (One b) |

524 | +digitToTree' n (One a) = n `seq` Single a |

525 | + |

526 | +{-# INLINE scanlSize #-} |

527 | +scanlSize :: (Traversable f, Sized a) => (b -> Int -> b) -> b -> f a -> f b |

528 | +scanlSize f z d = snd (mapAccumL (\ acc x -> let ans = f acc (size x) in (ans, ans)) z d) |

529 | + |

530 | +{-# INLINE scanrSize #-} |

531 | +scanrSize :: (Traversable f, Sized a) => (Int -> b -> b) -> b -> f a -> f b |

532 | +scanrSize f z d = snd (mapAccumR (\ acc x -> let ans = size x `f` acc in (ans, ans)) z d) |

533 | + |

534 | +{-# INLINE tailPr #-} |

535 | +-- | Given a Deep FingerTree, constructs the prefix of its tree of tails. |

536 | +tailPr :: Sized a => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a) |

537 | +tailPr n pr m sf = n `seq` let t = Deep n pr m sf in case (pr, scanlSize (-) n pr) of |

538 | + (One _, _) -> One t |

539 | + (Two a b, Two sza _) |

540 | + -> sza `seq` Two t (Deep sza (One b) m sf) |

541 | + (Three a b c, Three sza szb _) |

542 | + -> szb `seq` Three t (Deep sza (Two b c) m sf) (Deep szb (One c) m sf) |

543 | + (Four a b c d, Four sza szb szc _) |

544 | + -> szc `seq` Four t (Deep sza (Three b c d) m sf) (Deep szb (Two c d) m sf) |

545 | + (Deep szc (One d) m sf) |

546 | + |

547 | +{-# INLINE initPr #-} |

548 | +-- | Constructs the inits of the specified digits. |

549 | +initPr :: Sized a => Digit a -> Digit (FingerTree a) |

550 | +initPr pr = case (pr, scanlSize (+) 0 pr) of |

551 | + (One a, _) -> One (Single a) |

552 | + (Two a b, Two _ szb) |

553 | + -> szb `seq` Two (Single a) (digitToTree' szb (Two a b)) |

554 | + (Three a b c, Three _ szb szc) |

555 | + -> szc `seq` Three (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c)) |

556 | + (Four a b c d, Four _ szb szc szd) |

557 | + -> szd `seq` Four (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c)) |

558 | + (digitToTree' szd (Four a b c d)) |

559 | + |

560 | +{-# INLINE tailSf #-} |

561 | +-- | Constructs the tails of the specified digit. |

562 | +tailSf :: Sized a => Digit a -> Digit (FingerTree a) |

563 | +tailSf sf = case (sf, scanrSize (+) 0 sf) of |

564 | + (One a, _) -> One (Single a) |

565 | + (Two a b, Two sza _) |

566 | + -> sza `seq` Two (digitToTree' sza (Two a b)) (Single b) |

567 | + (Three a b c, Three sza szb _) |

568 | + -> sza `seq` Three (digitToTree' sza (Three a b c)) (digitToTree' szb (Two b c)) |

569 | + (Single c) |

570 | + (Four a b c d, Four sza szb szc _) |

571 | + -> sza `seq` Four (digitToTree' sza (Four a b c d)) (digitToTree' szb (Three b c d)) |

572 | + (digitToTree' szc (Two c d)) (Single d) |

573 | + |

574 | +{-# INLINE initSf #-} |

575 | +-- | Constructs the suffix of the tree of inits of the specified Deep tree. |

576 | +initSf :: (Sized a) => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a) |

577 | +initSf n pr m sf = n `seq` let t = Deep n pr m sf in case (sf, (scanrSize subtract n sf)) of |

578 | + (One _, _) -> One t |

579 | + (Two a b, Two sza _) |

580 | + -> sza `seq` Two (Deep sza pr m (One a)) t |

581 | + (Three a b c, Three sza szb _) |

582 | + -> sza `seq` Three (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) t |

583 | + (Four a b c d, Four sza szb szc _) |

584 | + -> sza `seq` Four (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) (Deep szc pr m (Three a b c)) t |

585 | + |

586 | +{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-} |

587 | +{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-} |

588 | +-- | Given a function to apply to tails of a tree, applies that function to every tail of the specified tree. |

589 | +tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b |

590 | +tailsTree _ Empty = Empty |

591 | +tailsTree f (Single x) = Single (f (Single x)) |

592 | +tailsTree f (Deep n pr m sf) = sfSize `seq` |

593 | + Deep n (fmap f (tailPr n pr m sf)) (tailsTree f' m) (fmap f (tailSf sf)) |

594 | + where sfSize = size sf |

595 | + f' ms = case viewLTree ms of |

596 | + Nothing2 -> error "tailsTree should not encounter empty tails" |

597 | + Just2 (Node2 n' a b) m' -> let sz2 = sz + size a; sz = size b + size m' + sfSize in |

598 | + sz2 `seq` Node2 n' (f (Deep sz2 (Two a b) m' sf)) |

599 | + (f (Deep sz (One b) m' sf)) |

600 | + Just2 (Node3 n' a b c) m' -> |

601 | + let sz = size c + size m' + sfSize |

602 | + sz2 = size b + sz |

603 | + sz3 = size a + sz2 |

604 | + in sz3 `seq` Node3 n' (f (Deep sz3 (Three a b c) m' sf)) |

605 | + (f (Deep sz2 (Two b c) m' sf)) |

606 | + (f (Deep sz (One c) m' sf)) |

607 | + |

608 | +{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-} |

609 | +{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-} |

610 | +-- | Given a function to apply to inits of a tree, applies that function to every init of the specified tree. |

611 | +initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b |

612 | +initsTree _ Empty = Empty |

613 | +initsTree f (Single x) = Single (f (Single x)) |

614 | +initsTree f (Deep n pr m sf) = prSize `seq` |

615 | + Deep n (fmap f (initPr pr)) (initsTree f' m) (fmap f (initSf n pr m sf)) |

616 | + where prSize = size pr |

617 | + f' ms = case viewRTree ms of |

618 | + Nothing2 -> error "initsTree should not encounter empty inits" |

619 | + Just2 m' (Node2 n' a b) -> let sza = prSize + size m' + size a; szb = sza + size b in szb `seq` |

620 | + Node2 n' (f (Deep sza pr m' (One a))) |

621 | + (f (Deep szb pr m' (Two a b))) |

622 | + Just2 m' (Node3 n' a b c) -> let sza = prSize + size m' + size a |

623 | + szb = sza + size b |

624 | + szc = szb + size c in |

625 | + szc `seq` Node3 n' (f (Deep sza pr m' (One a))) |

626 | + (f (Deep szb pr m' (Two a b))) |

627 | + (f (Deep szc pr m' (Three a b c))) |

628 | + |

629 | split :: Int -> FingerTree (Elem a) -> |

630 | (FingerTree (Elem a), FingerTree (Elem a)) |

631 | split i Empty = i `seq` (Empty, Empty) |

632 | hunk ./Data/Sequence.hs 1375 |

633 | Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf) |

634 | | i < spm = case splitTree im m of |

635 | Split ml xs mr -> case splitNode (im - size ml) xs of |

636 | - Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) |

637 | + Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) |

638 | | otherwise = case splitDigit (i - spm) sf of |

639 | hunk ./Data/Sequence.hs 1377 |

640 | - Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) |

641 | + Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) |

642 | where spr = size pr |

643 | spm = spr + size m |

644 | im = i - spr |

645 | hunk ./Data/Sequence.hs 1382 |

646 | |

647 | +{-# SPECIALIZE pullL :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-} |

648 | +{-# SPECIALIZE pullL :: Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node a) #-} |

649 | +pullL :: Sized a => Digit a -> FingerTree (Node a) -> FingerTree a |

650 | +pullL pr m = case viewRTree m of |

651 | + Nothing2 -> digitToTree pr |

652 | + Just2 m' sf -> Deep (size pr + size m) pr m' (nodeToDigit sf) |

653 | + |

654 | +{-# SPECIALIZE pullR :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

655 | +{-# SPECIALIZE pullR :: FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

656 | +pullR :: Sized a => FingerTree (Node a) -> Digit a -> FingerTree a |

657 | +pullR m sf = case viewLTree m of |

658 | + Nothing2 -> digitToTree sf |

659 | + Just2 pr m' -> Deep (size sf + size m) (nodeToDigit pr) m' sf |

660 | + |

661 | {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} |

662 | {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} |

663 | deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a |

664 | hunk ./Data/Sequence.hs 1399 |

665 | -deepL Nothing m sf = case viewLTree m of |

666 | - Nothing2 -> digitToTree sf |

667 | - Just2 a m' -> Deep (size m + size sf) (nodeToDigit a) m' sf |

668 | +deepL Nothing m sf = pullR m sf |

669 | deepL (Just pr) m sf = deep pr m sf |

670 | |

671 | {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-} |

672 | hunk ./Data/Sequence.hs 1405 |

673 | {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-} |

674 | deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a |

675 | -deepR pr m Nothing = case viewRTree m of |

676 | - Nothing2 -> digitToTree pr |

677 | - Just2 m' a -> Deep (size pr + size m) pr m' (nodeToDigit a) |

678 | +deepR pr m Nothing = pullL pr m |

679 | deepR pr m (Just sf) = deep pr m sf |

680 | |

681 | {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-} |

682 | hunk ./Data/Sequence.hs 1445 |

683 | sab = sa + size b |

684 | sabc = sab + size c |

685 | |

686 | +-- | /O(i)/ where /i/ is the breakpoint index. 'takeWhile', applied to a predicate @p@ and a sequence @xs@, returns the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@. |

687 | +takeWhile :: (a -> Bool) -> Seq a -> Seq a |

688 | +takeWhile p xs = fst (span p xs) |

689 | + |

690 | +-- | /O(i)/ where /i/ is the breakpoint index. @'dropWhile' p xs@ returns the suffix remaining after @takeWhile p xs@. |

691 | +dropWhile :: (a -> Bool) -> Seq a -> Seq a |

692 | +dropWhile p xs = snd (span p xs) |

693 | + |

694 | +-- | /O(i)/ where /i/ is the breakpoint index. 'span', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@ and the second element is the remainder of the sequence. |

695 | +span :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

696 | +-- This doesn't make any more of a traversal than is necessary, exploiting the laziness of foldr and the structure preservation of mapAccumL. |

697 | +span p xs = splitAt ix xs |

698 | + where indexed = snd (mapAccumL (\ i x -> i `seq` (i + 1, (x, i))) 0 xs) |

699 | + ix = foldr (\ (x, i) i' -> if p x then i' else i) (length xs) indexed |

700 | + |

701 | +-- | /O(i)/ where /i/ is the breakpoint index. 'break', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that /do not satisfy/ @p@ and the second element is the remainder of the sequence. |

702 | +break :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

703 | +break p xs = span (not . p) xs |

704 | + |

705 | +-- | /O(n)/. The 'partition' function takes a predicate @p@ and a sequence @xs@ and returns sequences of those elements which do and do not satisfy the predicate. |

706 | +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) |

707 | +partition p = foldl' partition' (empty, empty) where |

708 | + partition' (xs, ys) x |

709 | + | p x = (xs |> x, ys) |

710 | + | otherwise = (xs, ys |> x) |

711 | + |

712 | +-- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence @xs@ and returns a sequence of those elements which satisfy the predicate. |

713 | +filter :: (a -> Bool) -> Seq a -> Seq a |

714 | +filter p = foldl' filter' empty where |

715 | + filter' ys x |

716 | + | p x = ys |> x |

717 | + | otherwise = ys |

718 | + |

719 | ------------------------------------------------------------------------ |

720 | -- Lists |

721 | ------------------------------------------------------------------------ |

722 | hunk ./Data/Sequence.hs 1504 |

723 | (reverseTree (reverseNode f) m) |

724 | (reverseDigit f pr) |

725 | |

726 | +{-# INLINE reverseDigit #-} |

727 | reverseDigit :: (a -> a) -> Digit a -> Digit a |

728 | reverseDigit f (One a) = One (f a) |

729 | reverseDigit f (Two a b) = Two (f b) (f a) |

730 | hunk ./Data/Sequence.hs 1515 |

731 | reverseNode f (Node2 s a b) = Node2 s (f b) (f a) |

732 | reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a) |

733 | |

734 | +------------------------------------------------------------------------ |

735 | +-- Zipping |

736 | +-- |

737 | +-- We implement zipping on sequences by zipping left and right digits simultaneously and |

738 | +-- processing excess appropriately. This allows several elements to be ``zipped'' |

739 | +-- in a single go, which is significantly faster than it might be for a linked-list approach, |

740 | +-- where we'd have to do at least one dereference for each element. |

741 | +------------------------------------------------------------------------ |

742 | + |

743 | +-- | /O(n)/. 'zip' takes two sequences and returns a sequence of corresponding pairs. |

744 | +-- If one input is short, excess elements of the longer sequence are discarded. |

745 | +zip :: Seq a -> Seq b -> Seq (a, b) |

746 | +zip = zipWith (,) |

747 | + |

748 | +-- | /O(n)/. 'zipWith' generalizes 'zip' by zipping with the function given as the first argument, |

749 | +-- instead of a tupling function. For example, @zipWith (+)@ is applied to two sequences to take |

750 | +-- the sequence of corresponding sums. |

751 | +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c |

752 | +zipWith f xs ys |

753 | + | length xs <= length ys = zipWith' f xs ys |

754 | + | otherwise = zipWith' (flip f) ys xs |

755 | + where zipWith' f xs ys = |

756 | + let zipper ys x = case viewl ys of |

757 | + EmptyL -> error "zipper should never encounter an empty second string" |

758 | + y :< ys -> (ys, f x y) |

759 | + in snd (mapAccumL zipper ys xs) |

760 | + |

761 | +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) |

762 | +zip3 = zipWith3 (,,) |

763 | + |

764 | +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d |

765 | +zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3 |

766 | + |

767 | +zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d) |

768 | +zip4 = zipWith4 (,,,) |

769 | + |

770 | +zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e |

771 | +zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4 |

772 | + |

773 | +------------------------------------------------------------------------ |

774 | +-- Sorting |

775 | +-- |

776 | +-- This is an unstable heap sort implementation based on pairing heaps. Because the internal structure of |

777 | +-- sequences is quite varied, it is difficult to get blocks of elements of roughly the same length, which |

778 | +-- would improve merge sort performance. Pairing heaps, on the other hand, are relatively resistant to the |

779 | +-- effects of merging heaps of wildly different sizes, as guaranteed by its amortized constant-time merge |

780 | +-- operation. Moreover, extensive use of SpecConstr transformations can be done on pairing heaps, |

781 | +-- especially when we're only constructing them to immediately be unrolled. |

782 | +-- |

783 | +-- On purely random sequences, I get the following statistics: |

784 | +-- |

785 | +-- Times (ms) min mean +/-sd median max |

786 | +-- to/from list: 52.506 54.734 1.097 54.487 59.053 |

787 | +-- pairing heap: 29.966 30.402 0.753 30.253 35.372 |

788 | +-- |

789 | +-- In addition, on strictly increasing sequences, I get the following measurements: |

790 | +-- |

791 | +-- Times (ms) min mean +/-sd median max |

792 | +-- to/from list: 31.788 33.924 1.431 33.835 41.310 |

793 | +-- pairing heap: 8.578 9.029 0.289 8.956 10.066 |

794 | +-- |

795 | +-- These measurements are with no RTS options. With +RTS -H128m, on pure random sequences of length 50000, |

796 | +-- the margin is considerably thinner, but still in place. |

797 | +-- |

798 | +-- Times (ms) min mean +/-sd median max |

799 | +-- to/from list: 28.262 43.814 5.922 43.127 55.574 |

800 | +-- pairing heap: 23.953 38.682 4.811 39.536 51.857 |

801 | + |

802 | +-- |

803 | +-- In exchange for such a significant increase in performance, forcing users to convert to and |

804 | +-- from lists to get a stable sort seems acceptable. (The idiom is (fromList . Data.List.sort . toList), |

805 | +-- which is sufficiently short not to be a major issue.) |

806 | +-- |

807 | +-- wasserman.louis@gmail.com, 7/16/09 |

808 | +------------------------------------------------------------------------ |

809 | + |

810 | +-- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural ordering of its elements. The sort is not stable. |

811 | +-- The fastest way to stably sort a 'Seq' is to convert it to a list, use 'Data.List.sort', and convert it back to a 'Seq'. |

812 | +sort :: Ord a => Seq a -> Seq a |

813 | +sort = sortBy compare |

814 | + |

815 | +-- | /O(n log n)/. A generalization of 'sort', 'sortBy' takes an arbitrary comparator and sorts the specified sequence. The sort is not stable. |

816 | +-- The fastest way to stably sort a 'Seq' is to convert it to a list, use 'Data.List.sortBy', and convert it back to a 'Seq'. |

817 | +sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a |

818 | + -- Todo: examine whether or not stable sorting could be brute-forced by adding an index tag to PQueues. |

819 | +sortBy cmp (Seq xs) = fromList2 (size xs) $ maybe [] (unrollPQ cmp) $ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs |

820 | + --fromList . Data.List.sortBy cmp . toList |

821 | + |

822 | +fromList2 :: Int -> [a] -> Seq a |

823 | +-- fromList2, given a list and its length, constructs a completely balanced Seq whose elements are that list |

824 | +-- using the applicativeTree generalization. |

825 | +fromList2 n xs = Seq (execState (applicativeTree n 1 (State run)) xs) where |

826 | + run (x:xs) = (xs, Elem x) |

827 | + |

828 | +-- | A 'PQueue' is a simple pairing heap. |

829 | +data PQueue e = PQueue e (PQL e) |

830 | + |

831 | +data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e |

832 | + -- admittedly a glorified list of PQueues, but nevertheless encourages SpecConstr use |

833 | + |

834 | +infixr 8 :& |

835 | + |

836 | +#if TESTING |

837 | + |

838 | +instance Functor PQueue where |

839 | + fmap f (PQueue x ts) = PQueue (f x) (fmap f ts) |

840 | + |

841 | +instance Functor PQL where |

842 | + fmap f (q :& qs) = fmap f q :& fmap f qs |

843 | + fmap f Nil = Nil |

844 | + |

845 | +instance Show e => Show (PQueue e) where |

846 | + show = unlines . draw . fmap show |

847 | + |

848 | +-- borrowed wholesale from Data.Tree, as Data.Tree actually depends on Data.Sequence |

849 | +draw :: PQueue String -> [String] |

850 | +draw (PQueue x ts0) = x : drawSubTrees ts0 |

851 | + where drawSubTrees Nil = [] |

852 | + drawSubTrees (t :& Nil) = |

853 | + "|" : shift "`- " " " (draw t) |

854 | + drawSubTrees (t :& ts) = |

855 | + "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts |

856 | + |

857 | + shift first other = Data.List.zipWith (++) (first : repeat other) |

858 | +#endif |

859 | + |

860 | +-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into a sorted list. |

861 | +unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e] |

862 | +unrollPQ cmp = unrollPQ' where |

863 | + {-# INLINE unrollPQ' #-} |

864 | + unrollPQ' (PQueue x ts) = x:mergePQs0 ts |

865 | + (<>) = mergePQ cmp |

866 | + mergePQs0 Nil = [] |

867 | + mergePQs0 (t :& Nil) = unrollPQ' t |

868 | + mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts |

869 | + mergePQs t ts = t `seq` case ts of |

870 | + Nil -> unrollPQ' t |

871 | + t1 :& Nil -> unrollPQ' (t <> t1) |

872 | + t1 :& t2 :& ts -> mergePQs (t <> (t1 <> t2)) ts |

873 | + |

874 | +-- | 'toPQ', given an ordering function and a mechanism for queueifying elements, converts a 'FingerTree' to a 'PQueue'. |

875 | +toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e) |

876 | +toPQ cmp f (Deep _ pr m sf) = Just $ case toPQ cmp fNode m of |

877 | + Nothing -> fDig pr <> fDig sf |

878 | + Just m' -> fDig pr <> m' <> fDig sf |

879 | + where fNode (Node2 _ a b) = f a <> f b |

880 | + fNode (Node3 _ a b c) = f a <> f b <> f c |

881 | + (<>) = mergePQ cmp |

882 | + fDig (One a) = f a |

883 | + fDig (Two a b) = f a <> f b |

884 | + fDig (Three a b c) = f a <> f b <> f c |

885 | + fDig (Four a b c d) = (f a <> f b) <> (f c <> f d) |

886 | +toPQ _ f (Single x) = Just (f x) |

887 | +toPQ _ _ Empty = Nothing |

888 | + |

889 | +-- | 'mergePQ' merges two 'PQueue's. |

890 | +mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a |

891 | +mergePQ cmp (PQueue x1 ts1) (PQueue x2 ts2) |

892 | + | cmp x1 x2 == GT = PQueue x2 (PQueue x1 ts1 :& ts2) |

893 | + | otherwise = PQueue x1 (PQueue x2 ts2 :& ts1) |

894 | + |

895 | #if TESTING |

896 | |

897 | ------------------------------------------------------------------------ |

898 | hunk ./Data/Sequence.hs 1684 |

899 | |

900 | instance Arbitrary a => Arbitrary (Seq a) where |

901 | arbitrary = liftM Seq arbitrary |

902 | - coarbitrary (Seq x) = coarbitrary x |

903 | + shrink (Seq x) = map Seq (shrink x) |

904 | |

905 | instance Arbitrary a => Arbitrary (Elem a) where |

906 | arbitrary = liftM Elem arbitrary |

907 | hunk ./Data/Sequence.hs 1688 |

908 | - coarbitrary (Elem x) = coarbitrary x |

909 | + shrink _ = [] |

910 | |

911 | instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where |

912 | arbitrary = sized arb |

913 | hunk ./Data/Sequence.hs 1697 |

914 | arb 1 = liftM Single arbitrary |

915 | arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary |

916 | |

917 | - coarbitrary Empty = variant 0 |

918 | - coarbitrary (Single x) = variant 1 . coarbitrary x |

919 | - coarbitrary (Deep _ pr m sf) = |

920 | - variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf |

921 | + shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b] |

922 | + shrink (Deep _ pr m sf) = [deep pr' m sf | pr' <- shrink pr] ++ [deep pr m' sf | m' <- shrink m] ++ [deep pr m sf' | sf' <- shrink sf] |

923 | + shrink (Single _) = [Empty] |

924 | + shrink Empty = [] |

925 | |

926 | instance (Arbitrary a, Sized a) => Arbitrary (Node a) where |

927 | arbitrary = oneof [ |

928 | hunk ./Data/Sequence.hs 1707 |

929 | liftM2 node2 arbitrary arbitrary, |

930 | liftM3 node3 arbitrary arbitrary arbitrary] |

931 | |

932 | - coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b |

933 | - coarbitrary (Node3 _ a b c) = |

934 | - variant 1 . coarbitrary a . coarbitrary b . coarbitrary c |

935 | + shrink (Node2 _ a b) = [node2 a' b | a' <- shrink a] ++ [node2 a b' | b' <- shrink b] |

936 | + shrink (Node3 _ a b c) = [node2 a b, node2 a c, node2 b c] ++ |

937 | + [node3 a' b c | a' <- shrink a] ++ [node3 a b' c | b' <- shrink b] ++ [node3 a b c' | c' <- shrink c] |

938 | |

939 | instance Arbitrary a => Arbitrary (Digit a) where |

940 | arbitrary = oneof [ |

941 | hunk ./Data/Sequence.hs 1717 |

942 | liftM2 Two arbitrary arbitrary, |

943 | liftM3 Three arbitrary arbitrary arbitrary, |

944 | liftM4 Four arbitrary arbitrary arbitrary arbitrary] |

945 | - |

946 | - coarbitrary (One a) = variant 0 . coarbitrary a |

947 | - coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b |

948 | - coarbitrary (Three a b c) = |

949 | - variant 2 . coarbitrary a . coarbitrary b . coarbitrary c |

950 | - coarbitrary (Four a b c d) = |

951 | - variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d |

952 | + |

953 | + shrink (One a) = map One (shrink a) |

954 | + shrink (Two a b) = [One a, One b] |

955 | + shrink (Three a b c) = [Two a b, Two a c, Two b c] |

956 | + shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d] |

957 | |

958 | ------------------------------------------------------------------------ |

959 | -- Valid trees |

960 | hunk ./containers.cabal 23 |

961 | location: http://darcs.haskell.org/packages/containers/ |

962 | |

963 | Library { |

964 | - build-depends: base, array |

965 | + build-depends: base >= 4.0.0.0, array |

966 | exposed-modules: |

967 | Data.Graph |

968 | Data.IntMap |

969 | } |

970 | |

971 | Context: |

972 | |

973 | [Use left/right rather than old/new to describe the arguments to unionWithKey |

974 | Ian Lynagh <igloo@earth.li>**20090208192132 |

975 | Fixes trac #3002. |

976 | ] |

977 | [help nhc98 by making import decl more explicit |

978 | Malcolm.Wallace@cs.york.ac.uk**20090203142144] |

979 | [Add instance Data.Traversable for IntMap |

980 | Matti Niemenmaa <matti.niemenmaa+darcs@iki.fi>**20090116190353 |

981 | Ignore-this: df88a286935926aecec3f8a5dd291699 |

982 | ] |

983 | [Require Cabal version >= 1.6 |

984 | Ian Lynagh <igloo@earth.li>**20090122011256] |

985 | [Add "bug-reports" and "source-repository" info to the Cabal file |

986 | Ian Lynagh <igloo@earth.li>**20090121182106] |

987 | [Fix warnings in containers |

988 | Ian Lynagh <igloo@earth.li>**20090116200251] |

989 | [optimize IntMap/IntSet findMin/findMax |

990 | sedillard@gmail.com**20081002152055] |

991 | [O(n) fromAscList IntSet / IntMap |

992 | sedillard@gmail.com**20080521195941 |

993 | |

994 | Added algorithm by Scott Dillard and Bertram Felgenhauer to build IntSets and |

995 | IntMaps from sorted input in linear time. Also changed quickcheck prop_Ordered |

996 | (no longer a tautology!) to include negative and duplicate keys. |

997 | |

998 | ] |

999 | [correct type for IntMap.intersectionWith[Key] |

1000 | sedillard@gmail.com**20081002144828] |

1001 | [Export mapAccumRWithKey from Map and IntMap (Trac #2769) |

1002 | matti.niemenmaa+darcs@iki.fi**20081210160205] |

1003 | [Bump the version number to 0.2.0.1, to work-around cabal-install problems |

1004 | Ian Lynagh <igloo@earth.li>**20081212201829] |

1005 | [Fix #2760: change mkNorepType to mkNoRepType |

1006 | 'Jose Pedro Magalhaes <jpm@cs.uu.nl>'**20081202083424] |

1007 | [Doc fix, from hackage trac #378 |

1008 | Ian Lynagh <igloo@earth.li>**20081024143949] |

1009 | [import Data.Data instead of Data.Generics.*, eliminating the dependency on syb |

1010 | Ross Paterson <ross@soi.city.ac.uk>**20081005002559] |

1011 | [fixed typo in highestBitMask |

1012 | sedillard@gmail.com**20081002215438] |

1013 | [export Data.Map.toDescList, foldlWithKey, and foldrWithKey (trac ticket 2580) |

1014 | qdunkan@gmail.com**20080922213200 |

1015 | |

1016 | toDescList was previously implemented, but not exported. |

1017 | |

1018 | foldlWithKey was previously implemented, but not exported. It can be used to |

1019 | implement toDescList. |

1020 | |

1021 | foldrWithKey is already exported as foldWithKey, but foldrWithKey is explicitly |

1022 | the mirror of foldlWithKey, and foldWithKey kept for compatibility. |

1023 | ] |

1024 | [Bump version number to 0.2.0.0 |

1025 | Ian Lynagh <igloo@earth.li>**20080920160016] |

1026 | [TAG 6.10 branch has been forked |

1027 | Ian Lynagh <igloo@earth.li>**20080919123438] |

1028 | [Fixed typo in updateMinWithKey / updateMaxWithKey |

1029 | sedillard@gmail.com**20080704054350] |

1030 | [follow library changes |

1031 | Ian Lynagh <igloo@earth.li>**20080903223610] |

1032 | [add include/Typeable.h to extra-source-files |

1033 | Ross Paterson <ross@soi.city.ac.uk>**20080831181402] |

1034 | [fix cabal build-depends for nhc98 |

1035 | Malcolm.Wallace@cs.york.ac.uk**20080828104248] |

1036 | [Add a dep on syb |

1037 | Ian Lynagh <igloo@earth.li>**20080825214314] |

1038 | [add category field |

1039 | Ross Paterson <ross@soi.city.ac.uk>**20080824003013] |

1040 | [we depend on st, now split off from base |

1041 | Ian Lynagh <igloo@earth.li>**20080823223053] |

1042 | [specialize functions that fail in a Monad to Maybe (proposal #2309) |

1043 | Ross Paterson <ross@soi.city.ac.uk>**20080722154812 |

1044 | |

1045 | Specialize functions signatures like |

1046 | |

1047 | lookup :: (Monad m, Ord k) => k -> Map k a -> m a |

1048 | to |

1049 | lookup :: (Ord k) => k -> Map k a -> Maybe a |

1050 | |

1051 | for simplicity and safety. No information is lost, as each of these |

1052 | functions had only one use of fail, which is now changed to Nothing. |

1053 | ] |

1054 | [tighter description of split (addresses #2447) |

1055 | Ross Paterson <ross@soi.city.ac.uk>**20080717064838] |

1056 | [Make warning-clean with GHC again |

1057 | Ian Lynagh <igloo@earth.li>**20080623232023 |

1058 | With any luck we have now converged on a solution that works everywhere! |

1059 | ] |

1060 | [Undo more Data.Typeable-related breakage for non-ghc. |

1061 | Malcolm.Wallace@cs.york.ac.uk**20080623092757] |

1062 | [Placate GHC with explicit import lists |

1063 | Ian Lynagh <igloo@earth.li>**20080620183926] |

1064 | [undo breakage caused by -Wall cleaning |

1065 | Malcolm.Wallace@cs.york.ac.uk**20080620093922 |

1066 | The import of Data.Typeable is still required, at least for non-GHC. |

1067 | ] |

1068 | [Make the package -Wall clean |

1069 | Ian Lynagh <igloo@earth.li>**20080618233627] |

1070 | [List particular extensions rather than -fglasgow-exts |

1071 | Ian Lynagh <igloo@earth.li>**20080616232035] |

1072 | [Avoid using deprecated flags |

1073 | Ian Lynagh <igloo@earth.li>**20080616145241] |

1074 | [TAG 2008-05-28 |

1075 | Ian Lynagh <igloo@earth.li>**20080528004309] |

1076 | Patch bundle hash: |

1077 | 34a6b333944f7de1e11f31999b2894092a7f0acc |