ralist 0.2.1.1 → 0.4.1.0
raw patch · 8 files changed
Files
- Data/RAList.hs +0/−601
- benchmark/benchmarking.hs +22/−28
- changelog.md +30/−4
- ralist.cabal +20/−11
- src/Data/RAList.hs +1034/−0
- src/Data/RAList/Co.hs +411/−0
- src/Data/RAList/Internal.hs +19/−0
- tests/hspec.hs +149/−0
− Data/RAList.hs
@@ -1,601 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DeriveFoldable , DeriveTraversable#-}--- |--- A random-access list implementation based on Chris Okasaki's approach--- on his book \"Purely Functional Data Structures\", Cambridge University--- Press, 1998, chapter 9.3.------ 'RAList' is a replacement for ordinary finite lists.--- 'RAList' provides the same complexity as ordinary for most the list operations.--- Some operations take /O(log n)/ for 'RAList' where the list operation is /O(n)/,--- notably indexing, '(!!)'.----module Data.RAList- (- RAList-- -- * Basic functions- , empty- , cons- , uncons--- , singleton- , (++)- , head- , last- , tail- , init- , null- , length-- -- * Indexing lists- -- | These functions treat a list @xs@ as a indexed collection,- -- with indices ranging from 0 to @'length' xs - 1@.-- , (!!)- ,lookupWithDefault- ,lookupM- ,lookup-- --- * KV indexing- --- | This function treats a RAList as an association list- ,lookupL--- -- * List transformations- , map- , reverse-{-RA- , intersperse- , intercalate- , transpose-- , subsequences- , permutations-- -- * Reducing lists (folds)--}- , foldl- , foldl'- , foldl1- , foldl1'- , foldr- , foldr1-- -- ** Special folds-- , concat- , concatMap- , and- , or- , any- , all- , sum- , product- , maximum- , minimum-- -- * Building lists-{-RA- -- ** Scans- , scanl- , scanl1- , scanr- , scanr1-- -- ** Accumulating maps- , mapAccumL- , mapAccumR--}- -- ** Repetition- , replicate--{-RA- -- ** Unfolding- , unfoldr--}-- -- * Sublists-- -- ** Extracting sublists- , take- , drop- , simpleDrop- , splitAt-{-RA-- , takeWhile- , dropWhile- , dropWhileEnd- , span- , break-- , stripPrefix-- , group-- , inits- , tails-- -- ** Predicates- , isPrefixOf- , isSuffixOf- , isInfixOf--}- -- * Searching lists-- -- ** Searching by equality- , elem- , notElem--{-RA- -- ** Searching with a predicate- , find--}- , filter- , partition--{-RA- , elemIndex- , elemIndices-- , findIndex- , findIndices--}- -- * Zipping and unzipping lists-- , zip-{-RA- , zip3- , zip4, zip5, zip6, zip7--}- , zipWith-{-RA- , zipWith3- , zipWith4, zipWith5, zipWith6, zipWith7--}- , unzip-{-RA- , unzip3- , unzip4, unzip5, unzip6, unzip7-- -- * Special lists-- -- ** Functions on strings- , lines- , words- , unlines- , unwords-- -- ** \"Set\" operations-- , nub-- , delete- , (\\)-- , union- , intersect-- -- ** Ordered lists- , sort- , insert-- -- * Generalized functions-- -- ** The \"@By@\" operations-- -- *** User-supplied equality (replacing an @Eq@ context)- -- | The predicate is assumed to define an equivalence.- , nubBy- , deleteBy- , deleteFirstsBy- , unionBy- , intersectBy- , groupBy-- -- *** User-supplied comparison (replacing an @Ord@ context)- -- | The function is assumed to define a total ordering.- , sortBy- , insertBy- , maximumBy- , minimumBy-- -- ** The \"@generic@\" operations- -- | The prefix \`@generic@\' indicates an overloaded function that- -- is a generalized version of a "Prelude" function.-- , genericLength- , genericTake- , genericDrop- , genericSplitAt- , genericIndex- , genericReplicate--}- -- * Update- , update- , adjust- -- * List conversion- , toList- , fromList- ) where-import qualified Prelude-import Prelude hiding(- (++), head, last, tail, init, null, length, map, reverse,- foldl, foldl1, foldr, foldr1, concat, concatMap,- and, or, any, all, sum, product, maximum, minimum, take,- drop, elem, splitAt, notElem, lookup, replicate, (!!), filter,- zip, zipWith, unzip- )-import qualified Data.List as List-#if !MIN_VERSION_base(4,9,0) == 1-import Data.Monoid(Monoid,mappend,mempty)-#endif-import Data.Semigroup(Semigroup,(<>))-import Data.Data(Data,Typeable)-import Data.Functor.Identity(runIdentity)-import Data.Word--infixl 9 !!-infixr 5 `cons`, ++---- A RAList is stored as a list of trees. Each tree is a full binary tree.--- The sizes of the trees are monotonically increasing, except that the two--- first trees may have the same size.--- The first few tree sizes:--- [ [], [1], [1,1], [3], [1,3], [1,1,3], [3,3], [7], [1,7], [1,1,7],--- [3,7], [1,3,7], [1,1,3,7], [3,3,7], [7,7], [15], ...--- (I.e., skew binary numbers.)-data RAList a = RAList {-# UNPACK #-} !Word64 !(Top a)- deriving (Eq,Data,Typeable,Foldable,Traversable)--instance (Show a) => Show (RAList a) where- showsPrec p xs = showParen (p >= 10) $ showString "fromList " . showsPrec 10 (toList xs)--instance (Read a) => Read (RAList a) where- readsPrec p = readParen (p > 10) $ \ r -> [(fromList xs, t) | ("fromList", s) <- lex r, (xs, t) <- reads s]--instance (Ord a) => Ord (RAList a) where- xs < ys = toList xs < toList ys- xs <= ys = toList xs <= toList ys- xs > ys = toList xs > toList ys- xs >= ys = toList xs >= toList ys- xs `compare` ys = toList xs `compare` toList ys--instance Monoid (RAList a) where- mempty = empty- mappend = (<>)--instance Semigroup (RAList a) where- (<>) = (++)--instance Functor RAList where- fmap f (RAList s wts) = RAList s (fmap f wts)--instance Applicative RAList where- pure = \x -> RAList 1 (Cons 1 (Leaf x) Nil)- (<*>) = zipWith ($)--instance Monad RAList where- return = pure- (>>=) = flip concatMap---- Special list type for (Word64, Tree a), i.e., Top a ~= [(Word64, Tree a)]-data Top a = Nil | Cons {-# UNPACK #-} !Word64 !(Tree a) (Top a)- deriving (Eq,Data,Typeable,Functor,Foldable,Traversable)----instance Functor Top where--- fmap _ Nil = Nil--- fmap f (Cons w t xs) = Cons w (fmap f t) (fmap f xs)---- Complete binary tree. The completeness of the trees is an invariant that must--- be preserved for the implementation to work.-data Tree a- = Leaf a- | Node a !(Tree a) !(Tree a)- deriving (Eq,Data,Typeable,Functor,Foldable,Traversable)----instance Functor Tree where--- fmap f (Leaf x) = Leaf (f x)--- fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)---------empty :: RAList a-empty = RAList 0 Nil---- | Complexity /O(1)/.-cons :: a -> RAList a -> RAList a-cons x (RAList s wts) = RAList (s+1) $- case wts of- Cons s1 t1 (Cons s2 t2 wts') | s1 == s2 -> Cons (1 + s1 + s2) (Node x t1 t2) wts'- _ -> Cons 1 (Leaf x) wts--(++) :: RAList a -> RAList a -> RAList a-xs ++ ys | null ys = xs -- small optimization to avoid consing to empty- | otherwise = foldr cons ys xs---uncons :: RAList a -> Maybe (a, RAList a)-uncons (RAList _ Nil) = Nothing-uncons (RAList s (Cons _ (Leaf h) wts)) = Just (h,RAList (s-1) wts)-uncons (RAList s (Cons w (Node x l r) wts)) = Just (x, RAList (s-1) (Cons w2 l (Cons w2 r wts)))- where w2 = w `quot` 2---- | Complexity /O(1)/.-head :: RAList a -> Maybe a-head = fmap fst . uncons---- | Complexity /O(log n)/.-last :: RAList a -> a-last xs@(RAList s _) = xs !! (s-1)--half :: Word64 -> Word64-half n = n `quot` 2---- | Complexity /O(log n)/.-(!!) :: RAList a -> Word64 -> a-RAList s wts !! n | n < 0 = error "Data.RAList.!!: negative index"- | n >= s = error "Data.RAList.!!: index too large"- | otherwise = ix n wts- where ix j (Cons w t wts') | j < w = ixt j (w `quot` 2) t- | otherwise = ix (j-w) wts'- ix _ _ = error "Data.RAList.!!: impossible"- ixt 0 0 (Leaf x) = x- ixt 0 _ (Node x _l _r) = x- ixt j w (Node _x l r) | j <= w = ixt (j-1) (w `quot` 2) l- | otherwise = ixt (j-1-w) (w `quot` 2) r- ixt _j _w _ = error "Data.RAList.!!: impossible"--lookup :: forall a. Word64 -> Top a -> a-lookup i xs = runIdentity (lookupM i xs)--lookupM :: forall (m :: * -> *) a. Monad m => Word64 -> Top a -> m a-lookupM jx zs = look zs jx- where look Nil _ = fail "RandList.lookup bad subscript"- look (Cons j t xs) i- | i < j = lookTree j t i- | otherwise = look xs (i - j)-- lookTree _ (Leaf x) i- | i == 0 = return x- | otherwise = nothing- lookTree j (Node 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"- --- this wont fly long term--lookupWithDefault :: forall t. t -> Word64 -> Top t -> t-lookupWithDefault d jx zs = look zs jx- where look Nil _ = d- look (Cons j t xs) i- | i < j = lookTree j t i- | otherwise = look xs (i - j)-- lookTree _ (Leaf x) i- | i == 0 = x- | otherwise = d- lookTree j (Node 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---- | Complexity /O(1)/.-tail :: RAList a -> Maybe (RAList a)-tail = fmap snd . uncons--- XXX Is there some clever way to do this?-init :: RAList a -> RAList a-init = fromList . Prelude.init . toList--null :: RAList a -> Bool-null (RAList s _) = s == 0---- | Complexity /O(1)/.-length :: RAList a -> Word64-length (RAList s _) = s--map :: (a->b) -> RAList a -> RAList b-map = fmap----reverse :: RAList a -> RAList a-reverse = fromList . Prelude.reverse . toList---- XXX All the folds could be done more effiently.-foldl :: (a -> b -> a) -> a -> RAList b -> a-foldl f z xs = Prelude.foldl f z (toList xs)--foldl' :: (a -> b -> a) -> a -> RAList b -> a-foldl' f z xs = List.foldl' f z (toList xs)--foldl1 :: (a -> a -> a) -> RAList a -> a-foldl1 f xs | null xs = errorEmptyList "foldl1"- | otherwise = Prelude.foldl1 f (toList xs)--foldl1' :: (a -> a -> a) -> RAList a -> a-foldl1' f xs | null xs = errorEmptyList "foldl1'"- | otherwise = List.foldl1' f (toList xs)---- XXX This could be deforested.-foldr :: (a -> b -> b) -> b -> RAList a -> b-foldr f z xs = Prelude.foldr f z (toList xs)--foldr1 :: (a -> a -> a) -> RAList a -> a-foldr1 f xs | null xs = errorEmptyList "foldr1"- | otherwise = Prelude.foldr1 f (toList xs)--concat :: RAList (RAList a) -> RAList a-concat = foldr (++) empty--concatMap :: (a -> RAList b) -> RAList a -> RAList b-concatMap f = concat . map f--and :: RAList Bool -> Bool-and = foldr (&&) True--or :: RAList Bool -> Bool-or = foldr (||) False--any :: (a -> Bool) -> RAList a -> Bool-any p = or . map p--all :: (a -> Bool) -> RAList a -> Bool-all p = and . map p--sum :: (Num a) => RAList a -> a-sum = foldl (+) 0--product :: (Num a) => RAList a -> a-product = foldl (*) 1--maximum :: (Ord a) => RAList a -> a-maximum xs | null xs = errorEmptyList "maximum"- | otherwise = foldl1 max xs--minimum :: (Ord a) => RAList a -> a-minimum xs | null xs = errorEmptyList "minimum"- | otherwise = foldl1 min xs--replicate :: Word64 -> a -> RAList a-replicate n v = fromList $ Prelude.replicate (fromIntegral n) v--take :: Word64 -> RAList a -> RAList a-take n ls | n < fromIntegral (maxBound :: Int) = fromList $ Prelude.take (fromIntegral n) $ toList ls- | otherwise = ls---- | drop i l--- @`drop` i l@ where l has length n has worst case complexity Complexity /O(log n)/, Average case--- complexity should be /O(min(log i, log n))/.-drop :: Word64 -> RAList a -> RAList a-drop n xs | n <= 0 = xs-drop n _xs@(RAList s _) | n >= s = empty-drop n (RAList s wts) = RAList (s-n) (loop n wts)- where loop 0 xs = xs- loop m (Cons w _ xs) | w <= m = loop (m-w) xs -- drops full trees- loop m (Cons w tre xs) = splitTree m w tre xs -- splits tree- loop _ _ = error "Data.RAList.drop: impossible"---- helper function for drop--- drops the first n elements of the tree and adds them to the front-splitTree :: Word64 -> Word64 -> Tree a -> Top a -> Top a-splitTree n treeSize tree@(Node _ l r) xs =- case (compare n 1, n <= halfTreeSize) of- (LT {- n==0 -}, _ ) -> Cons treeSize tree xs- (EQ {- n==1 -}, _ ) -> Cons halfTreeSize l (Cons halfTreeSize r xs)- (_, True ) -> splitTree (n-1) halfTreeSize l (Cons halfTreeSize r xs)- (_, False) -> splitTree (n-halfTreeSize-1) halfTreeSize r xs- where halfTreeSize = treeSize `quot` 2-splitTree n treeSize nd@(Leaf _) xs =- case compare n 1 of- EQ {-1-} -> xs- LT {-0-}-> Cons treeSize nd xs- GT {- > 1-} -> error "drop invariant violated, must be smaller than current tree"------- Old version of drop--- worst case complexity /O(n)/-simpleDrop :: Word64 -> RAList a -> RAList a-simpleDrop n xs | n <= 0 = xs-simpleDrop n _xs@(RAList s _) | n >= s = empty-simpleDrop n (RAList s wts) = RAList (s-n) (loop n wts)- where loop 0 xs = xs- loop n1 (Cons w _ xs) | w <= n1 = loop (n1-w) xs- loop n2 (Cons w (Node _ l r) xs) = loop (n2-1) (Cons w2 l (Cons w2 r xs))- where w2 = w `quot` 2- loop _ _ = error "Data.RAList.drop: impossible"---splitAt :: Word64 -> RAList a -> (RAList a, RAList a)-splitAt n xs = (take n xs, drop n xs)--elem :: (Eq a) => a -> RAList a -> Bool-elem x = any (== x)--notElem :: (Eq a) => a -> RAList a -> Bool-notElem x = not . elem x -- aka all (/=)---- naive list based lookup-lookupL :: (Eq a) => a -> RAList (a, b) -> Maybe b-lookupL x xys = Prelude.lookup x (toList xys)--filter :: (a->Bool) -> RAList a -> RAList a-filter p xs =- case uncons xs of- Nothing -> empty- Just(h,tl) ->- let- ys = filter p tl- in- if p h then h `cons` ys else ys---partition :: (a->Bool) -> RAList a -> (RAList a, RAList a)-partition p xs = (filter p xs, filter (not . p) xs)-----zip :: RAList a -> RAList b -> RAList (a, b)-zip = zipWith (,)--zipWith :: (a->b->c) -> RAList a -> RAList b -> RAList c-zipWith f xs1@(RAList s1 wts1) xs2@(RAList s2 wts2)- | s1 == s2 = RAList s1 (zipTop wts1 wts2)- | otherwise = fromList $ Prelude.zipWith f (toList xs1) (toList xs2)- where zipTree (Leaf x1) (Leaf x2) = Leaf (f x1 x2)- zipTree (Node x1 l1 r1) (Node x2 l2 r2) = Node (f x1 x2) (zipTree l1 l2) (zipTree r1 r2)- zipTree _ _ = error "Data.RAList.zipWith: impossible"- zipTop Nil Nil = Nil- zipTop (Cons w t1 xss1) (Cons _ t2 xss2) = Cons w (zipTree t1 t2) (zipTop xss1 xss2)- zipTop _ _ = error "Data.RAList.zipWith: impossible"--unzip :: RAList (a, b) -> (RAList a, RAList b)-unzip xs = (map fst xs, map snd xs)---- | Change element at the given index.--- Complexity /O(log n)/.-update :: Word64 -> a -> RAList a -> RAList a-update i x = adjust (const x) i---- | Apply a function to the value at the given index.--- Complexity /O(log n)/.-adjust :: (a->a) -> Word64 -> RAList a -> RAList a-adjust f n (RAList s wts) | n < 0 = error "Data.RAList.adjust: negative index"- | n >= s = error "Data.RAList.adjust: index too large"- | otherwise = RAList s (adj n wts)- where adj j (Cons w t wts') | j < w = Cons w (adjt j (w `quot` 2) t) wts'- | otherwise = Cons w t (adj (j-w) wts')- adj j _ = error ("Data.RAList.adjust: impossible Nil element: " <> show j)- adjt 0 0 (Leaf x) = Leaf (f x)- adjt 0 _ (Node x l r) = Node (f x) l r- adjt j w (Node x l r) | j <= w = Node x (adjt (j-1) (w `quot` 2) l) r- | otherwise = Node x l (adjt (j-1-w) (w `quot` 2) r)- adjt _ _ _ = error "Data.RAList.adjust: impossible"---- XXX Make this a good producer--- | Complexity /O(n)/.-toList :: RAList a -> [a]-toList (RAList _ wts) = tops wts []- where flat (Leaf x) a = x : a- flat (Node x l r) a = x : flat l (flat r a)- tops Nil r = r- tops (Cons _ t xs) r = flat t (tops xs r)---- XXX Use number system properties to make this more efficient.--- | Complexity /O(n)/.-fromList :: [a] -> RAList a-fromList = Prelude.foldr cons empty--errorEmptyList :: String -> a-errorEmptyList fun =- error ("Data.RAList." Prelude.++ fun Prelude.++ ": empty list")
benchmark/benchmarking.hs view
@@ -3,61 +3,55 @@ import Criterion.Main import Data.RAList +{-# NOINLINE hundred #-} hundred :: RAList Int hundred = fromList [0..100] +{-# NOINLINE thousand#-} thousand :: RAList Int thousand = fromList [0..1000] +{-# NOINLINE tenThousand#-} tenThousand :: RAList Int tenThousand = fromList [0..10000] hundredThousand :: RAList Int hundredThousand = fromList [0..100000] -million :: RAList Int-million = fromList [0..1000000]+--million :: RAList Int+--million = fromList [0..1000000] -tenMillion :: RAList Int-tenMillion = fromList [0..10000000]+--tenMillion :: RAList Int+--tenMillion = fromList [0..10000000] main = defaultMain [ bgroup "drop"- [ bench "TenThousand" $ whnf (Data.RAList.drop 100) tenThousand,- bench "HundredThousand" $ whnf (Data.RAList.drop 100) hundredThousand,- bench "Million" $ whnf (Data.RAList.drop 100) million,- bench "TenMillion" $ whnf (Data.RAList.drop 100) tenMillion,+ [ bench "Thousand" $ whnf (Data.RAList.drop 100) thousand - bench "TenThousand-Drop1" $ whnf (Data.RAList.drop 1) tenThousand,- bench "HundredThousand-Drop1" $ whnf (Data.RAList.drop 1) hundredThousand,- bench "Million-Drop1" $ whnf (Data.RAList.drop 1) million,- bench "TenMillion-Drop1" $ whnf (Data.RAList.drop 1) tenMillion+ ,bench "Thousand-Drop1" $ whnf (Data.RAList.drop 1) thousand+ --bench "HundredThousand-Drop1" $ whnf (Data.RAList.drop 1) hundredThousand+ --bench "Million-Drop1" $ whnf (Data.RAList.drop 1) million,+ --bench "TenMillion-Drop1" $ whnf (Data.RAList.drop 1) tenMillion ], bgroup "simpleDrop"- [ bench "TenThousand" $ whnf (Data.RAList.simpleDrop 100) tenThousand,- bench "HundredThousand" $ whnf (Data.RAList.simpleDrop 100) hundredThousand,- bench "Million" $ whnf (Data.RAList.simpleDrop 100) million,- bench "TenMillion" $ whnf (Data.RAList.simpleDrop 100) tenMillion,+ [ bench "Thousand" $ whnf (Data.RAList.simpleDrop 100) thousand - bench "TenThousand-Drop1" $ whnf (Data.RAList.simpleDrop 1) tenThousand,- bench "HundredThousand-Drop1" $ whnf (Data.RAList.simpleDrop 1) hundredThousand,- bench "Million-Drop1" $ whnf (Data.RAList.simpleDrop 1) million,- bench "TenMillion-Drop1" $ whnf (Data.RAList.simpleDrop 1) tenMillion+ ,bench "Thousand-Drop1" $ whnf (Data.RAList.simpleDrop 1) thousand+ ], bgroup "cons"- [ bench "hundred" $ whnf (Data.RAList.cons 0) hundred,- bench "thousand" $ whnf (Data.RAList.cons 0) thousand+ [ bench "hundred" $ whnf (Data.RAList.cons 0) hundred+ ,bench "thousand" $ whnf (Data.RAList.cons 0) thousand ], bgroup "uncons"- [ bench "hundred" $ whnf Data.RAList.uncons hundred,- bench "thousand" $ whnf Data.RAList.uncons thousand+ [ bench "hundred" $ whnf Data.RAList.uncons hundred+ ,bench "thousand" $ whnf Data.RAList.uncons thousand ], bgroup "lookup last element"- [ bench "TenThousand" $ whnf (tenThousand Data.RAList.!!) 10000,- bench "HundredThousand" $ whnf (hundredThousand Data.RAList.!!) 100000,- bench "Million" $ whnf (million Data.RAList.!!) 1000000,- bench "TenMillion" $ whnf (tenMillion Data.RAList.!!) 10000000+ [ bench "TenThousand" $ whnf (tenThousand Data.RAList.!!) 10000+ --,bench "HundredThousand" $ whnf (hundredThousand Data.RAList.!!) 100000+ ] ]
changelog.md view
@@ -1,8 +1,34 @@+# 0.4.1.0 +- **Bug fix**: `Data.RAList.Co` — off-by-one in all index operations (`!!`, `lookup`, `lookupM`, `lookupWithDefault`, `lookupCC`). Index formula was `length - n` instead of `length - 1 - n`.+- **Bug fix**: `Data.RAList.Co.adjust` — infinite recursion (called itself instead of `QRA.adjust`).+- **Bug fix**: `Data.RAList.Co.genericReplicate` — infinite recursion (called itself instead of `QRA.genericReplicate`).+- Widened dependency bounds for GHC 9.14 (base < 6, deepseq < 1.7, transformers < 0.7, hspec < 2.12).+- Added test coverage for `Data.RAList.Co` (35 new tests).++# 0.4.0.0++- Breaking change to api to make api flavors more consistent.++# 0.3.0.0++- Added `Data.RAList.Co` module for reversed (co-indexed) access lists.+- Added filter/catMaybe/wither family of operations.+- Added NFData/NFData1 instances.+- Added indexed traversal instances (FunctorWithIndex, FoldableWithIndex, TraversableWithIndex).++# 0.2.1.1++- Documentation tweaks.+ # 0.2.1.0-Added missing traversable instance +- Various improvements.+ # 0.2.0.0-updated version of ralist-includes bug fixes, api cleanup,-test suite and logarithmic drop contributed by Nell White++- Major rework by Carter Schonwald.++# 0.1.0.0++- Initial release by Lennart Augustsson.
ralist.cabal view
@@ -1,6 +1,6 @@-Cabal-Version: 2.2+cabal-version: 3.0 Name: ralist-Version: 0.2.1.1+Version: 0.4.1.0 License: BSD-3-Clause license-file: LICENSE Author: Lennart Augustsson, Carter Schonwald@@ -16,6 +16,7 @@ -- URL for the project homepage or repository. homepage: http://github.com/cartazio/ralist +tested-with: GHC==9.14.1, GHC==8.10.2, GHC==8.8.4, GHC==8.6.5 extra-source-files: changelog.md LICENSE @@ -27,17 +28,25 @@ Library- Build-Depends: base >= 3 && < 6- Exposed-modules: Data.RAList+ Build-Depends:+ base >= 4.12 && < 6+ ,indexed-traversable >= 0.1 && < 0.2+ , transformers >= 0.5 && < 0.7+ -- only needed for one spot in .co+ ,deepseq >= 1.4.4.0 && < 1.7+ Exposed-modules:+ Data.RAList+ ,Data.RAList.Co+ ,Data.RAList.Internal ghc-options: -Wall -O2+ hs-source-dirs: src default-language: Haskell2010- -- Build-depends: semigroups == 0.18.*- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances- else- -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8- build-depends: fail == 4.9.*, semigroups == 0.18.*+ if impl(ghc >= 8.0 )+ if impl(ghc < 8.10 )+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances ++ test-suite hspec type: exitcode-stdio-1.0 @@ -50,7 +59,7 @@ build-depends: base, ralist,- hspec >= 2.2 && < 2.7+ hspec >= 2.2 && < 2.12 benchmark benchmarking
+ src/Data/RAList.hs view
@@ -0,0 +1,1034 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable,DeriveAnyClass,DerivingVia #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExplicitForAll, RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PatternSynonyms,ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE DeriveFoldable , DeriveTraversable,DeriveGeneric#-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses#-}+{-# LANGUAGE MonadComprehensions,RoleAnnotations #-}+{-# LANGUAGE Trustworthy#-}++-- |+-- A random-access list implementation based on Chris Okasaki's approach+-- on his book \"Purely Functional Data Structures\", Cambridge University+-- Press, 1998, chapter 9.3.+--+-- 'RAList' is a replacement for ordinary finite lists.+-- 'RAList' provides the same complexity as ordinary for most the list operations.+-- Some operations take /O(log n)/ for 'RAList' where the list operation is /O(n)/,+-- notably indexing, '(!!)'.+--+module Data.RAList+ (+ RAList(Nil,Cons,(:|))++ -- * Basic functions+ --, empty+ , cons+ , uncons+-- , singleton+ , (++)+ , head+ , last+ , tail+ , init+ , null+ , length++ -- * Indexing lists+ -- | These functions treat a list @xs@ as a indexed collection,+ -- with indices ranging from 0 to @'length' xs - 1@.++ , (!!)+ ,lookupWithDefault+ ,lookupM+ ,lookup+ ,lookupCC++ --- * KV indexing+ --- | This function treats a RAList as an association list+ ,lookupL+++ -- * List transformations+ , map+ , reverse+{-RA+ , intersperse+ , intercalate+ , transpose++ , subsequences+ , permutations+-}++ -- * indexed operations+ ,imap+ ,itraverse+ ,ifoldMap+ ,ifoldl'+ ,ifoldr++++ -- * Reducing lists (folds)++ , foldl+ , foldl'+ , foldl1+ , foldl1'+ , foldr+ , foldr1+++ -- ** Special folds++ , concat+ , concatMap+ , and+ , or+ , any+ , all+ , sum+ , product+ , maximum+ , minimum++ -- * Building lists+{-RA+ -- ** Scans+ , scanl+ , scanl1+ , scanr+ , scanr1++ -- ** Accumulating maps+ , mapAccumL+ , mapAccumR+-}+ -- ** Repetition+ , replicate+++ -- ** Unfolding+ , unfoldr+++ -- * Sublists++ -- ** Extracting sublists+ , take+ , drop+ , simpleDrop+ , splitAt+{-RA++ , takeWhile+ , dropWhile+ , dropWhileEnd+ , span+ , break++ , stripPrefix++ , group++ , inits+ , tails++ -- ** Predicates+ , isPrefixOf+ , isSuffixOf+ , isInfixOf+-}+ -- * Searching lists++ -- ** Searching by equality+ , elem+ , notElem++{-RA+ -- ** Searching with a predicate+ , find+-}+ , filter+ , partition+ , mapMaybe+ , catMaybes+ , wither++{-RA+ , elemIndex+ , elemIndices++ , findIndex+ , findIndices+-}+ -- * Zipping and unzipping lists++ , zip+{-RA+ , zip3+ , zip4, zip5, zip6, zip7+-}+ , zipWith+{-RA+ , zipWith3+ , zipWith4, zipWith5, zipWith6, zipWith7+-}+ , unzip+{-RA+ , unzip3+ , unzip4, unzip5, unzip6, unzip7++ -- * Special lists++ -- ** Functions on strings+ , lines+ , words+ , unlines+ , unwords++ -- ** \"Set\" operations++ , nub++ , delete+ , (\\)++ , union+ , intersect++ -- ** Ordered lists+ , sort+ , insert++ -- * Generalized functions++ -- ** The \"@By@\" operations++ -- *** User-supplied equality (replacing an @Eq@ context)+ -- | The predicate is assumed to define an equivalence.+ , nubBy+ , deleteBy+ , deleteFirstsBy+ , unionBy+ , intersectBy+ , groupBy++ -- *** User-supplied comparison (replacing an @Ord@ context)+ -- | The function is assumed to define a total ordering.+ , sortBy+ , insertBy+ , maximumBy+ , minimumBy+-}+ -- ** The \"@generic@\" operations+ -- | The prefix \`@generic@\' indicates an overloaded function that+ -- is a generalized version of a "Prelude" function.++ , genericLength+ , genericTake+ , genericDrop+ , genericSplitAt+ , genericIndex+ , genericReplicate++ -- * Update+ , update+ , adjust+ -- * List conversion+ , toList+ , fromList+ -- * List style fusion tools+ , build+ , augment++ , wLength+ ) where+import qualified Prelude+import Prelude hiding(+ (++), head, last, tail, init, null, length, map, reverse,+ foldl, foldl1, foldr, foldr1, concat, concatMap,+ and, or, any, all, sum, product, maximum, minimum, take,+ drop, elem, splitAt, notElem, lookup, replicate, (!!), filter,+ zip, zipWith, unzip+ )+import qualified Data.List as List++-- this should be a cabal flag for debugging data structure bugs :)+#define DEBUG 0++#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup(Semigroup,(<>))+#endif+import Data.Data(Data,Typeable)+--import Data.Functor.Identity(runIdentity)+import Data.Word++import Data.Foldable as F hiding (concat, concatMap)+import qualified Control.Monad.Fail as MF++import Control.Monad.Zip+import Numeric.Natural++--import GHC.Exts (oneShot)++import qualified GHC.Exts as GE (IsList(..))++import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex++import Data.RAList.Internal+import Control.Applicative(Applicative(liftA2))++import GHC.Generics(Generic,Generic1)+++import Control.DeepSeq++infixl 9 !!+infixr 5 `cons`, +++infixr 5 `Cons`+infixr 5 :|++-- | our '[]' by another name+pattern Nil :: forall a. RAList a+pattern Nil = RNil++-- | Constructor notation ':'+pattern Cons :: forall a. a -> RAList a -> RAList a+pattern Cons x xs <-( uncons -> Just(x,xs) )+ where Cons x xs = cons x xs+{-# COMPLETE Nil,Cons #-}+++-- | like ':' but for RAList+pattern (:|) :: forall a. a -> RAList a -> RAList a+pattern x :| xs = Cons x xs+{-# COMPLETE (:|), Nil #-}++++-- A RAList is stored as a list of trees. Each tree is a full binary tree.+-- The sizes of the trees are monotonically increasing, except that the two+-- first trees may have the same size.+-- The first few tree sizes:+-- [ [], [1], [1,1], [3], [1,3], [1,1,3], [3,3], [7], [1,7], [1,1,7],+-- [3,7], [1,3,7], [1,1,3,7], [3,3,7], [7,7], [15], ...+-- (I.e., skew binary numbers.)+++type role RAList representational++-- Special list type for (Word64, Tree a), i.e., Top a ~= [(Word64, Tree a)]+data RAList a = RNil+ | RCons {-# UNPACK #-} !Word64 -- total number of elements, aka sum of subtrees+ {-# UNPACK #-} !Word64 -- size of this subtree+ (Tree a)+ (RAList a)+ deriving (Eq+ ,Data+ ,Typeable+ ,Functor+ ,Traversable+#if DEBUG+ , Show+#endif+ , Generic+ , Generic1+ ,NFData+ ,NFData1+ )+++#if !DEBUG+instance (Show a) => Show (RAList a) where+ showsPrec p xs = showParen (p >= 10) $ showString "fromList " . showsPrec 10 (toList xs)+#endif++--instance (Read a) => Read (RAList a) where+-- readsPrec p = readParen (p > 10) $ \ r -> [(fromList xs, t) | ("fromList", s) <- lex r, (xs, t) <- reads s]++instance (Ord a) => Ord (RAList a) where+ --- this is kinda naive, but simple for now+ xs < ys = toList xs < toList ys+ xs <= ys = toList xs <= toList ys+ xs > ys = toList xs > toList ys+ xs >= ys = toList xs >= toList ys+ xs `compare` ys = toList xs `compare` toList ys++instance Monoid (RAList a) where+ mempty = Nil+++instance Semigroup (RAList a) where+ {-# INLINE (<>) #-}+ (<>) = (++)++--instance Functor RAList where+-- fmap f (RAList s skewlist) = RAList s (fmap f skewlist)++--- lets just use MonadComprehensions to write out the applictives+instance Applicative RAList where+ {-# INLINE pure #-}+ pure = \x -> Cons x Nil+ {-# INLINE (<*>) #-}+ fs <*> xs = [f x | f <- fs, x <- xs]+ {-# INLINE liftA2 #-}+ liftA2 f xs ys = [f x y | x <- xs, y <- ys]+ {-# INLINE (*>) #-}+ xs *> ys = [y | _ <- xs, y <- ys]+++instance Monad RAList where+ return = pure+ (>>=) = flip concatMap++instance GE.IsList (RAList a) where+ type Item (RAList a) = a+ toList = toList+ fromList = fromList++instance MonadZip RAList where+ mzipWith = zipWith+ munzip = unzip++{-# INLINE unzip #-}+-- adapted from List definition in base+unzip :: RAList (a,b) -> (RAList a,RAList b)+unzip = foldr' (\(a,b) (!as,!bs) -> (a:| as,b:|bs)) (Nil,Nil)+--unzip = foldr (\(a,b) ~(as,bs) -> (a:| as,b:|bs)) (Nil,Nil)++--instance Traversable RAList where+ --{-# INLINE traverse #-} -- so that traverse can fuse+ -- deriving might be nice too, need to compare later+ --traverse f = foldr cons_f (pure Nil)+ --where cons_f x ys = liftA2 (cons) (f x) ys+++instance TraversableWithIndex Word64 RAList where+ {-# INLINE itraverse #-}+ itraverse = \ f s -> snd $ runIndexing (traverse (\a -> Indexing (\i -> i `seq` (i + 1, f i a))) s) 0+instance FoldableWithIndex Word64 RAList where+instance FunctorWithIndex Word64 RAList where++-- TODO: look into ways to make the toList more efficient if needed++instance Foldable RAList where+ {-# INLINE null#-}+ null = \ x -> case x of Nil -> True ; _ -> False+ {-# INLINE length #-}+ length = genericLength -- :)++++ -- This INLINE allows more list functions to fuse. See #9848.+ --{-# INLINE foldMap #-}+ --foldMap f = foldr (mappend . f) mempty+ --foldMap _f RNil = mempty+ --foldMap f (RCons _stot _stre tree rest) = foldMap f tree <> foldMap f rest++ foldMap = \(f:: a -> m) (ra:: RAList a ) ->+ let+ go :: RAList a -> m+ go ral = case ral of RNil -> mempty+ (RCons _stot _stre tree rest) -> foldMap f tree <> go rest+ in go ra++ --not sure if providing my own foldr is a good idea, but lets try for now : )+ --{-# INLINE [0] foldr #-}+ {-+ foldr f z = go+ where+ go Nil = z+ go (Cons y ys) = y `f` go ys+ -- {-# INLINE toList #-}+ toList = foldr (:) []+ -}++ --{-# INLINE foldl' #-}+{-+ foldl' k z0 xs =+ foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> z `seq` fn (k z v))) (id :: b -> b) xs z0+ -}+++--instance Functor Top where+-- fmap _ Nil = Nil+-- fmap f (Cons w t xs) = Cons w (fmap f t) (fmap f xs)++-- Complete binary tree. The completeness of the trees is an invariant that must+-- be preserved for the implementation to work.++{-# specialize genericLength :: RAList a -> Word64 #-}+{-# specialize genericLength :: RAList a -> Integer #-}+{-# specialize genericLength :: RAList a -> Int #-}+{-# specialize genericLength :: RAList a -> Word #-}+genericLength :: Integral w =>RAList a -> w+genericLength = \ra -> case ra of RNil -> 0 ; (RCons tot _trtot _tree _rest) -> fromIntegral tot++wLength :: RAList a -> Word64+wLength = genericLength++type role Tree representational+data Tree a+ = Leaf a+ | Node a (Tree a) (Tree a)+ deriving+ (Eq+ ,Data+ ,Typeable+ ,Functor+ ,NFData+ ,NFData1+ ,Generic+ ,Generic1+ ,Traversable+#if DEBUG+ , Show+#endif+ )++instance Foldable Tree where+ -- Tree is a PREORDER sequence layout+ foldMap f (Leaf a) = f a+ foldMap f (Node a l r) = f a <> foldMap f l <> foldMap f r+++--instance Functor Tree where+-- fmap f (Leaf x) = Leaf (f x)+-- fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)++-- todo audit inline pragmas for `cons`+-- also, i think we can say that cons is whnf strict in its second argument, lazy in the first?+{-# INLINE CONLIKE [0] cons #-}+-- | Complexity /O(1)/.+cons :: a -> RAList a -> RAList a+cons = \ x ls -> case ls of+ (RCons tots1 tsz1 t1+ (RCons _tots2 tsz2 t2 rest))+ | tsz2 == tsz1+ -> RCons (tots1 + 1) (tsz1 * 2 + 1 ) (Node x t1 t2 ) rest+ rlist -> RCons (1 + wLength rlist ) 1 (Leaf x) rlist+{-+cons x (RCons tots1 tsz1 t1+ (RCons _tots2 tsz2 t2 rest))+ | tsz2 == tsz1 = RCons (tots1 + 1) (tsz1 * 2 + 1 ) (Node x t1 t2 ) rest+cons x rlist = RCons (1 + wLength rlist ) 1 (Leaf x) rlist+-}++--(++) :: RAList a -> RAList a -> RAList a+--xs ++ Nil = xs+--Nil ++ ys = ys+--xs ++ ys = foldr cons ys xs++(++) :: RAList a -> RAList a-> RAList a+--{-# NOINLINE (++) #-} -- We want the RULE to fire first.+ -- It's recursive, so won't inline anyway,+ -- but saying so is more explicit+(++) Nil ys = ys+(++) xs Nil = xs+(++) (Cons x xs) ys = Cons x ( xs ++ ys)++-- {-# RULES+-- "RALIST/++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+-- #-}+++{-++ (++) :: [a] -> [a] -> [a]+ {-# NOINLINE [1] (++) #-} -- We want the RULE to fire first.+ -- It's recursive, so won't inline anyway,+ -- but saying so is more explicit+ (++) [] ys = ys+ (++) (x:xs) ys = x : xs ++ ys++ {-# RULES+ "++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+ #-}+++-}++uncons :: RAList a -> Maybe (a, RAList a)+uncons (RNil) = Nothing+uncons (RCons _tot _treetot (Leaf h) wts) = Just (h,wts)+uncons (RCons _tot w (Node x l r) wts) = Just (x, (RCons (restsize + w2 + w2) w2 l (RCons (restsize + w2) w2 r wts)))+ where+ w2 = w `quot` 2+ restsize = wLength wts++-- | Complexity /O(1)/.+head :: RAList a -> Maybe a+head = fmap fst . uncons++-- | Complexity /O(log n)/.+last :: RAList a -> a+last xs= xs !! (genericLength xs - 1)++half :: Word64 -> Word64+half = \ n -> n `quot` 2++-- | Complexity /O(log n)/.+(!!) :: RAList a -> Word64 -> a+r !! n | n < 0 = error "Data.RAList.!!: negative index"+ | n >= genericLength r = error "Data.RAList.!!: index too large"+ | otherwise = lookupCC r n id error+++lookupCC :: forall a r. RAList a -> Word64 -> (a -> r) -> (String -> r) -> r+lookupCC = \ ralist index retval retfail ->+ let+ look RNil _ = retfail "RAList.lookup bad subscript, something is corrupted"+ look (RCons _tots tsz t xs) ix+ | ix < tsz = lookTree tsz ix t+ | otherwise = look xs (ix - tsz)++ lookTree _ ix (Leaf x)+ | ix == 0 = retval x+ | otherwise = retfail "RAList.lookup: not found. somehow we reached a leaf but our index doesnt match, this is bad"+ lookTree jsz ix (Node x l r)+ | ix > (half jsz) = lookTree (half jsz) (ix - 1 - (half jsz)) r+ | ix /= 0 = lookTree (half jsz) (ix - 1) l -- ix between zero and floor of size/2+ | otherwise = retval x -- when ix is zero+ in+ if index >= (genericLength ralist)+ then retfail $ "provide index larger than Ralist max valid coord " <> (show index) <> " " <> (show (length ralist))+ else look ralist index+++lookup :: forall a. RAList a -> Word64 -> Maybe a+lookup = \ xs i -> lookupCC xs i Just (const Nothing)+++{-# SPECIALIZE genericIndex :: RAList a -> Integer -> a #-}+{-# SPECIALIZE genericIndex :: RAList a -> Word -> a #-}+{-# SPECIALIZE genericIndex :: RAList a -> Word64 -> a #-}+{-# SPECIALIZE genericIndex :: RAList a -> Int -> a #-}+{-# SPECIALIZE genericIndex :: RAList a -> Natural -> a #-}+genericIndex :: Integral n => RAList a -> n -> a+genericIndex ls ix | word64Representable ix = ls !! (fromIntegral ix)+ | otherwise = error "argument index for Data.RAList.genericIndex not representable in Word64"+++{-# SPECIALIZE lookupM :: forall a . RAList a -> Word64 -> Maybe a #-}+{-# SPECIALIZE lookupM :: forall a . RAList a -> Word64 -> IO a #-}+lookupM :: forall a m. MF.MonadFail m => RAList a -> Word64 -> m a+lookupM = \ ix lst -> lookupCC ix lst return fail++lookupWithDefault :: forall t. t -> Word64 -> RAList t -> t+lookupWithDefault = \ d tree ix -> lookupCC ix tree id (const d)+++-- | Complexity /O(1)/.+tail :: RAList a -> Maybe (RAList a)+tail = fmap snd . uncons+-- XXX Is there some clever way to do this?+init :: RAList a -> RAList a+init = fromList . Prelude.init . toList+++-- -- | Complexity /O(1)/.+--length :: RAList a -> Word64+--length (RCons s _treesize _tree _rest) = s+--length RNil = 0++map :: (a->b) -> RAList a -> RAList b+map = fmap+++--- adapted from ghc base+-- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.+-- @xs@ must be finite.+reverse :: RAList a -> RAList a+#if defined(USE_REPORT_PRELUDE)+reverse = foldl (flip cons) Nil+#else+reverse l = rev l Nil+ where+ rev Nil a = a+ rev (Cons x xs) a = rev xs (Cons x a)+#endif++++foldl1' :: (a -> a -> a) -> RAList a -> a+foldl1' f xs | null xs = errorEmptyList "foldl1'"+ | otherwise = List.foldl1' f (toList xs)++---- XXX This could be deforested.+--foldr :: (a -> b -> b) -> b -> RAList a -> b+--foldr f z xs = Prelude.foldr f z (toList xs)++--foldr1 :: (a -> a -> a) -> RAList a -> a+--foldr1 f xs | null xs = errorEmptyList "foldr1"+-- | otherwise = Prelude.foldr1 f (toList xs)++concat :: RAList (RAList a) -> RAList a+concat = foldr (<>) Nil+{-# INLINE concat #-}+-- {-# NOINLINE [1] concat #-}++-- {-# RULES+-- "concat" forall xs. concat xs =+-- build (\c n -> foldr (\x y -> foldr c y x) n xs)+-- -- We don't bother to turn non-fusible applications of concat back into concat+-- #-}++++concatMap :: (a -> RAList b) -> RAList a -> RAList b+--concatMap f = concat . fmap f+-- TODO: should this and others be foldr' ?+concatMap f = foldr ((++) . f) Nil+{-# INLINE concatMap #-}+--{-# NOINLINE [1] concatMap #-}++--{-# RULES+--"concatMap" forall f xs . concatMap f xs =+-- build (\c n -> foldr (\x b -> foldr c b (f x)) n xs)+ -- #-}++--and :: RAList Bool -> Bool+--and = foldr (&&) True++--or :: RAList Bool -> Bool+--or = foldr (||) False++--any :: (a -> Bool) -> RAList a -> Bool+--any p = or . map p++--all :: (a -> Bool) -> RAList a -> Bool+--all p = and . map p++--sum :: (Num a) => RAList a -> a+--sum = foldl (+) 0++--product :: (Num a) => RAList a -> a+--product = foldl (*) 1++--maximum :: (Ord a) => RAList a -> a+--maximum xs | null xs = errorEmptyList "maximum"+-- | otherwise = foldl1 max xs++--minimum :: (Ord a) => RAList a -> a+--minimum xs | null xs = errorEmptyList "minimum"+-- | otherwise = foldl1 min xs++replicate :: Word64 -> a -> RAList a+replicate n v = fromList $ Prelude.replicate (fromIntegral n) v++{-# SPECIALIZE genericReplicate :: Int -> a -> RAList a #-}+{-# SPECIALIZE genericReplicate :: Word -> a -> RAList a #-}+{-# SPECIALIZE genericReplicate :: Word64 -> a -> RAList a #-}+{-# SPECIALIZE genericReplicate :: Integer-> a -> RAList a #-}+{-# SPECIALIZE genericReplicate :: Natural -> a -> RAList a #-}+genericReplicate :: Integral n => n -> a -> RAList a+genericReplicate siz val+ | word64Representable siz = replicate (fromIntegral siz) val+ | siz < 0 = error "negative replicate size arg in Data.RAList.genericReplicate"+ | otherwise = error "too large integral arg to Data.Ralist.genericReplicate"++-- when converting from a non Word64 integral type to Word64, we want to make sure either+-- that the source integral type is representable / embedded within word64+-- OR that if its a type which can represent a Word64 value exactly, the value does+-- not exceed the size of the largest positive Word64 value. At least with Replicate :)+word64Representable :: Integral a => a -> Bool+word64Representable siz = fromIntegral siz <= (maxBound :: Word64) || siz <= fromIntegral (maxBound :: Word64)++-- unlike drop, i dont think we can do better than the list take in complexity+take :: Word64 -> RAList a -> RAList a+take n ls | n < (maxBound :: Word64) = fromList $ Prelude.take (fromIntegral n) $ toList ls+ | otherwise = ls++genericTake :: Integral n => n -> RAList a -> RAList a+genericTake siz ls | siz <= 0 = Nil+ | word64Representable siz = take (fromIntegral siz) ls+ | otherwise = error "too large integral arg for Data.RAList.genericTake"++-- | @`drop` i l@ where l has length n has worst case complexity Complexity /O(log n)/, Average case+-- complexity should be /O(min(log i, log n))/.+drop :: Word64 -> RAList a -> RAList a+drop n rlist | n <= 0 = rlist+drop n rlist | n >=( genericLength rlist) = Nil+drop n rlist = (loop n rlist)+ where loop 0 xs = xs+ loop m (RCons _tot treesize _ xs) | treesize <= m = loop (m-treesize) xs -- drops full trees+ loop m (RCons _tot treesize tre xs) = splitTree m treesize tre xs -- splits tree+ loop _ _ = error "Data.RAList.drop: impossible"+++genericDrop :: Integral n => n -> RAList a -> RAList a+genericDrop siz ls | siz <= 0 = ls+ | word64Representable siz = drop (fromIntegral siz) ls+ | otherwise = Nil -- because a list with more than putatively 2**64 elements :)++-- helper function for drop+-- drops the first n elements of the tree and adds them to the front+splitTree :: Word64 -> Word64 -> Tree a -> RAList a -> RAList a+splitTree n treeSize tree@(Node _ l r) xs =+ case (compare n 1, n <= half treeSize) of+ (LT {- n==0 -}, _ ) -> RCons (suffixSize + treeSize) treeSize tree xs+ (EQ {- n==1 -}, _ ) -> RCons (suffixSize + 2* halfTreeSize) halfTreeSize l+ (RCons (suffixSize + halfTreeSize) halfTreeSize r xs)+ (_, True ) -> splitTree (n-1) halfTreeSize l (RCons (suffixSize + halfTreeSize) halfTreeSize r xs)+ (_, False) -> splitTree (n-halfTreeSize-1) halfTreeSize r xs+ where suffixSize = genericLength xs+ halfTreeSize = half treeSize+splitTree n treeSize nd@(Leaf _) xs =+ case compare n 1 of+ EQ {-1-} -> xs+ LT {-0-}-> RCons ((genericLength xs) + treeSize) treeSize nd xs+ GT {- > 1-} -> error "drop invariant violated, must be smaller than current tree"++++-- Old version of drop+-- worst case complexity /O(n)/+simpleDrop :: Word64 -> RAList a -> RAList a+simpleDrop n xs | n <= 0 = xs+ | n >= (genericLength xs) = Nil+ | otherwise = (loop n xs)+ where loop 0 rs = rs+ loop m (RCons _tot w _ rs) | w <= m = loop (m-w) rs+ loop m (RCons _tot w (Node _ l r) rs) = loop (m-1) (RCons ((genericLength xs) + 2 * w2) w2 l (RCons ((genericLength xs) + w2) w2 r rs))+ where w2 = half w+ loop _ _ = error "Data.RAList.drop: impossible"+++-- we *could* try to do better here, but this is fine+splitAt :: Word64 -> RAList a -> (RAList a, RAList a)+splitAt n xs = (take n xs, drop n xs)++genericSplitAt :: Integral n => n -> RAList a -> (RAList a, RAList a)+genericSplitAt siz ls | siz <=0 = (Nil,ls)+ | word64Representable siz = (take (fromIntegral siz) ls, drop (fromIntegral siz) ls)+ | otherwise = (ls, Nil)++--elem :: (Eq a) => a -> RAList a -> Bool+--elem x = any (== x)++--notElem :: (Eq a) => a -> RAList a -> Bool+--notElem x = not . elem x -- aka all (/=)++-- naive list based lookup+lookupL :: (Eq a) => a -> RAList (a, b) -> Maybe b+lookupL x xys = Prelude.lookup x (toList xys)++-- catMaybes ls = mapMaybe Just ls+catMaybes :: RAList (Maybe a) -> RAList a+catMaybes = \ ls-> foldr' (\ a bs -> maybe bs (:| bs) a ) Nil ls++wither :: forall a b f . Applicative f => (a -> f (Maybe b)) -> RAList a -> f (RAList b)+wither f ls = foldr ((\ a fbs -> liftA2 (maybe id (cons)) (f a) fbs)) (pure Nil ) ls+++-- mapMaybe f ls === foldr' (\ a bs -> maybe bs (\b -> b :| bs ) $! f a) ls+mapMaybe :: forall a b . (a -> Maybe b) -> RAList a -> RAList b+mapMaybe = \ fm ls ->+ let+ go :: RAList a -> RAList b+ go Nil = Nil+ go (a:| as) | Just b <- fm a = b :| go as+ | otherwise = go as+ in+ go ls++-- wither f ls == foldr+++{-# NOINLINE [1] filter #-}+filter :: forall a . (a -> Bool) -> RAList a -> RAList a+filter = \ f ls ->+ let go :: RAList a -> RAList a+ go Nil = Nil+ go (a :| as) = if f a+ then a :| go as+ else go as+ in+ go ls+++--filter _p Nil = Nil+--filter p (Cons x xs)+-- | p x = x `Cons` filter p xs+-- | otherwise = filter p xs++++{-# INLINE [0] filterFB #-} -- See Note [Inline FB functions] in ghc base+filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+filterFB c p x r | p x = x `c` r+ | otherwise = r++--- ANY late rule is problematic that uses cons :(++{-# RULES+"RA/filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)+"RA/filterList" [1] forall p. foldr (filterFB (cons) p) RNil = filter p+"RA/filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)+ #-}+++partition :: (a->Bool) -> RAList a -> (RAList a, RAList a)+partition p xs = (filter p xs, filter (not . p) xs)++++zip :: RAList a -> RAList b -> RAList (a, b)+zip = zipWith (,)++zipWith :: forall a b c . (a->b->c) -> RAList a -> RAList b -> RAList c+zipWith f = \ xs1 xs2 ->+++ case compare (wLength xs1) (wLength xs2) of+ EQ -> zipTop xs1 xs2++ LT -> zipTop xs1+ (take (wLength xs1) xs2)++ GT -> zipTop (take (wLength xs2) xs1)+ xs2++ -- | s1 == s2 = RAList s1 (zipTop wts1 wts2)+ -- | otherwise = fromList $ Prelude.zipWith f (toList xs1) (toList xs2)+ where zipTree (Leaf x1) (Leaf x2) = Leaf (f x1 x2)+ zipTree (Node x1 l1 r1) (Node x2 l2 r2) = Node (f x1 x2) (zipTree l1 l2) (zipTree r1 r2)+ zipTree _ _ = error "Data.RAList.zipWith: impossible"+ zipTop :: RAList a -> RAList b -> RAList c+ zipTop RNil RNil = RNil+ zipTop (RCons tot1 w t1 xss1) (RCons _tot2 _ t2 xss2) = RCons tot1 w (zipTree t1 t2) (zipTop xss1 xss2)+ zipTop _ _ = error "Data.RAList.zipWith: impossible"++++-- | Change element at the given index.+-- Complexity /O(log n)/.+update :: Word64 -> a -> RAList a -> RAList a+update i x = adjust (const x) i++-- | Apply a function to the value at the given index.+-- Complexity /O(log n)/.+adjust :: forall a . (a->a) -> Word64 -> RAList a -> RAList a+adjust f n s | n < 0 = error "Data.RAList.adjust: negative index"+ | n >= (genericLength s) = error "Data.RAList.adjust: index too large"+ | otherwise = (adj n s )+ where adj :: Word64 -> RAList a -> RAList a+ adj j (RCons tot w t wts') | j < w = RCons tot w (adjt j (w `quot` 2) t) wts'+ | otherwise = RCons tot w t (adj (j-w) wts')+ adj j _ = error ("Data.RAList.adjust: impossible Nil element: " <> show j)++ adjt :: Word64 -> Word64 -> Tree a -> Tree a+ adjt 0 0 (Leaf x) = Leaf (f x)+ adjt 0 _ (Node x l r) = Node (f x) l r+ adjt j w (Node x l r) | j <= w = Node x (adjt (j-1) (w `quot` 2) l) r+ | otherwise = Node x l (adjt (j-1-w) (w `quot` 2) r)+ adjt _ _ _ = error "Data.RAList.adjust: impossible"++++-- | Complexity /O(n)/.+fromList :: [a] -> RAList a+fromList = Prelude.foldr Cons Nil++errorEmptyList :: String -> a+errorEmptyList fun =+ error ("Data.RAList." Prelude.++ fun Prelude.++ ": empty list")+++--- copy fusion codes of your own :) perhaps?+--- for now these fusion rules are shamelessly copied from the ghc base library++{-# INLINE [1] build #-}+--- a+build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> RAList a+build = \ g -> g cons Nil++unfoldr :: (b -> Maybe (a, b)) -> b -> RAList a+{-# INLINE unfoldr #-} -- See Note [INLINE unfoldr in ghc base library original source]+unfoldr f b0 = build (\c n ->+ let go b = case f b of+ Just (a, new_b) -> a `c` go new_b+ Nothing -> n+ in go b0)+++augment :: forall a. (forall b. (a->b->b) -> b -> b) -> RAList a -> RAList a+-- {-# INLINE [1] augment #-}+augment g xs = g cons xs++++--{-# RULES+--"RALIST/fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .+-- foldr k z (build g) = g k z+--+--"RALIST/foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .+-- foldr k z (augment g xs) = g k (foldr k z xs)+--+--+--"RALIST/augment/build" forall (g::forall b. (a->b->b) -> b -> b)+-- (h::forall b. (a->b->b) -> b -> b) .+-- augment g (build h) = build (\c n -> g c (h c n))+--+----- not sure if these latter rules will be useful for RALIST+--+--"RALIST/foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .+-- foldr k z (cons x (build g)) = k x (g k z)+--+--+--"RALIST/foldr/single" forall k z x. foldr k z (cons x RNil) = k x z+--"RALIST/foldr/nil" forall k z. foldr k z RNil = z+--+--+--"RALIST/foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .+-- foldr k z (cons x (build g)) = k x (g k z)+--+--"RALIST/augment/build" forall (g::forall b. (a->b->b) -> b -> b)+-- (h::forall b. (a->b->b) -> b -> b) .+-- augment g (build h) = build (\c n -> g c (h c n))+--"RALIST/augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .+-- augment g RNil = build g+--+--"RALIST/foldr/id" foldr (cons) RNil = \x -> x+--"RALIST/foldr/app" [1] forall ys. foldr (cons) ys = \xs -> xs ++ ys+-- -- Only activate this from phase 1, because that's+-- -- when we disable the rule that expands (++) into foldr+-- #-}++-- {-# RULES+-- "RALIST/++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+-- #-}++++{-+additional ru++"foldr/id" foldr (:) [] = \x -> x+ -- Only activate this from phase 1, because that's+ -- when we disable the rule that expands (++) into foldr++-- The foldr/cons rule looks nice, but it can give disastrously+-- bloated code when compiling+-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]+-- i.e. when there are very very long literal lists+-- So I've disabled it for now. We could have special cases+-- for short lists, I suppose.+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)++"foldr/single" forall k z x. foldr k z [x] = k x z+"foldr/nil" forall k z. foldr k z [] = z++"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .+ foldr k z (x:build g) = k x (g k z)++-}
+ src/Data/RAList/Co.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE RankNTypes, DerivingVia, DeriveTraversable, PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE BangPatterns,UndecidableInstances,MultiParamTypeClasses #-}+{-# LANGUAGE MonadComprehensions,RoleAnnotations, QuantifiedConstraints #-}+{-# LANGUAGE Trustworthy, MagicHash#-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.RAList.Co(+ --module RA+ RAList(Cons,Nil,RCons,(:|),(:.))++ -- * lookups+ , lookup+ , lookupM+ , lookupWithDefault+ , (!!)+ , lookupCC++ -- * function form of constructing and destructing+ ,cons+ ,uncons+ --,traverse+ --,foldr+ --,foldl+ --,foldl'++-- * zipping+ ,zip+ ,zipWith+ ,unzip++ --+-- * Extracting sublists+ , take+ , drop+ , replicate+ , splitAt++ -- * from traverse and foldable and ilk+ ,foldl'+ ,foldr+ ,traverse+ ,mapM+ ,mapM_++ ,unfoldr++ -- * indexed folds etc+ ,ifoldMap+ ,imap+ ,itraverse+ ,ifoldl'+ ,ifoldr+ ,imapM++-- * filter and friends+ , filter+ , partition+ , mapMaybe+ , catMaybes+ , wither++-- * foldable cousins++ ,elem+ ,length+ ,wLength+++-- * The \"@generic@\" operations+-- | The prefix \`@generic@\' indicates an overloaded function that+-- is a generalized version of a "Prelude" function.++ , genericLength+ , genericTake+ , genericDrop+ , genericSplitAt+ , genericIndex+ , genericReplicate++-- * Update+ , update+ , adjust+-- * Append+ ,(++)+-- * list conversion+, fromList+, toList++ ) where++++import Data.Word+--import qualified Prelude as P+import Prelude hiding (+ (++), head, last, tail, init, null, length, map, reverse,+ foldl, foldl1, foldr, foldr1, concat, concatMap,+ and, or, any, all, sum, product, maximum, minimum, take,+ drop, elem, splitAt, notElem, lookup, replicate, (!!), filter,+ zip, zipWith, unzip+ )+import Data.Foldable.WithIndex+import Data.Functor.WithIndex+import Data.Traversable.WithIndex++-- this is used to ... flip around the indexing+--- need to check that i'm doing it correctly of course+import Control.Applicative.Backwards++import Data.RAList.Internal+-- provides indexing applicative++--import qualfieData.RAList as RA hiding (+-- (!!)+-- ,lookupWithDefault+-- ,lookupM+-- ,lookup+-- , lookupCC )+import qualified Data.RAList as QRA+import qualified Control.Monad.Fail as MF+import Data.Foldable+import Data.Traversable()+import GHC.Exts (IsList)+import Control.Monad.Zip+import Data.Coerce+import GHC.Generics(Generic,Generic1)++import Control.Applicative(Applicative(liftA2))++import Data.Type.Coercion++import Unsafe.Coerce++import Control.DeepSeq++infixl 9 !!+infixr 5 `cons`, ++++-- | Cons pattern, à la ':' for list, prefix+infixr 5 `Cons`+pattern Cons :: forall a. a -> RAList a -> RAList a+pattern Cons x xs <- (uncons -> Just (x, xs ) )+ where Cons x xs = (cons x xs)+++-- | the '[]' analogue+pattern Nil :: forall a . RAList a+pattern Nil = CoIndex QRA.Nil++{-# COMPLETE Cons, Nil #-}+-- | just 'Cons' but flipped arguments+infixl 5 `RCons`+pattern RCons :: forall a. RAList a -> a -> RAList a+pattern RCons xs x = Cons x xs++{-# COMPLETE RCons, Nil #-}++-- | infix 'Cons', aka : , but for RAlist+infixr 5 :|+pattern (:|) :: forall a. a -> RAList a -> RAList a+pattern x :| xs = Cons x xs+{-# COMPLETE (:|), Nil #-}++-- | infix 'RCons', aka flipped :+infixl 5 :.+pattern (:.) :: forall a. RAList a -> a -> RAList a+pattern xs :. x = Cons x xs+{-# COMPLETE (:.), Nil #-}+++-- | friendly list to RAList conversion+fromList :: [a] -> RAList a+fromList = foldr Cons Nil+++++-- | This type (@'RAList' a@) indexes back to front, i.e. for nonempty lists @l@ : head of l == (l @'!!' ('genericLength'@ l - 1 ))@+-- and @last l == l '!!' 0 @. RAList also has a logarithmic complexity 'drop' operation, and different semantics for 'zip' and related operations+--+--+-- for complete pattern matching, you can use any pair of:+--+-- - ':|' , 'Nil'+--+-- - ':.' , 'Nil'+--+-- - 'Cons' , 'Nil'+--+-- - 'RCons' , 'Nil'+--+-- The Reversed order pattern synonyms are provided+-- to enable certain codes to match pen/paper notation for ordered variable environments+newtype RAList a = CoIndex {reindex :: QRA.RAList a }+ deriving stock (Traversable)+ --- should think about direction of traversal+ deriving (Foldable,Functor,Generic1,NFData1) via QRA.RAList+ deriving (Monoid,Semigroup,Eq,Ord,Show,IsList,Generic,NFData) via QRA.RAList a++type role RAList representational++--- > itraverse (\ix _val -> Id.Identity ix) $ ([(),(),(),()]:: Co.RAList ())+--- Identity (fromList [3,2,1,0])+--- but should this be done right to left or left to right??+instance TraversableWithIndex Word64 RAList where+ {-# INLINE itraverse #-}+ itraverse = \ f s -> snd $ runIndexing+ ( forwards $ traverse (\a -> Backwards $ Indexing (\i -> i `seq` (i + 1, f i a))) s) 0+-- TODO; benchmark this vs counting downn from the start++++instance FoldableWithIndex Word64 RAList where+instance FunctorWithIndex Word64 RAList where+++instance Applicative RAList where+ {-# INLINE pure #-}+ pure = \x -> Cons x Nil+ {-# INLINE (<*>) #-}+ fs <*> xs = [f x | f <- fs, x <- xs]+ {-# INLINE liftA2 #-}+ liftA2 f xs ys = [f x y | x <- xs, y <- ys]+ {-# INLINE (*>) #-}+ xs *> ys = [y | _ <- xs, y <- ys]++instance Monad RAList where+ return = pure+ (>>=) = (\ls f -> CoIndex $ QRA.concatMap (\ x -> coerce $ f x) $ reindex ls )++++--- QUESTION --- am i wrong for using the Ziplist applicative with my monads?+++{-++++if we have <*> === zipWith ($)+that means we need to have the monad be the DIAGONLIZATION rather than concat map++++we need ap === <*>++ap :: (Monad m) => m (a -> b) -> m a -> m b+ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }+-- Since many Applicative instances define (<*>) = ap, we+-- cannot define ap = (<*>)+-}+instance MonadZip RAList where+ mzipWith = zipWith+ munzip = unzip++-- | implementation underlying smart constructor used by pattern synonyms+cons :: a -> RAList a -> RAList a+cons x (CoIndex xs) = CoIndex $ QRA.cons x xs+++-- | how matching is implemented+uncons :: RAList a -> Maybe (a, RAList a)+uncons (CoIndex xs) = case QRA.uncons xs of+ Nothing -> Nothing+ Just(h,rest) -> Just (h,CoIndex rest)+++-- double check what the complexity is+-- | @'drop' i l@ drops the first @i@ elments, @O(log i)@ complexity,+drop :: Word64 -> RAList a -> RAList a+drop = \ ix (CoIndex ls)-> CoIndex $ QRA.drop ix ls++-- | @'take' i l@, keeps the first @i@ elements, @O(i)@ complexity+take :: Word64 -> RAList a -> RAList a+take = \ix (CoIndex ls ) -> CoIndex $ QRA.take ix ls++--- being lazy? yes :)+-- | performs both drop and take+splitAt :: Word64 -> RAList a -> (RAList a, RAList a )+splitAt = genericSplitAt+++-- | @'replicate' n a @ makes a RAList with n values of a+replicate :: Word64 -> a -> RAList a+replicate = genericReplicate++-- | list zip,+zip :: RAList a -> RAList b -> RAList (a, b)+zip = zipWith (,)++{-# INLINE unzip #-}+-- adapted from List definition in base+-- not perfectly certain about being lazy on the *rest*+-- but lets leave it for now... though i think my cons+-- algorithm precludes it from actually being properly lazy+-- TODO : mess with foldr' vs foldr and ~ vs ! for as and bs from unzip definition+unzip :: RAList (a,b) -> (RAList a,RAList b)+unzip = foldr' (\(a,b) (!as,!bs) -> (a:| as,b:|bs)) (Nil,Nil)++--unzip = foldr (\(a,b) ~(as,bs) -> (a:| as,b:|bs)) (Nil,Nil)++--- this zipWith has better efficiency than the opposite one+-- in the case of differing length RALists, because we can drop from the front+-- efficiently but not from the back!+-- we need to do this flip around+--- this semantic arise from counting the indexing from the rear in this module+zipWith :: (a -> b -> c ) -> RAList a -> RAList b -> RAList c+zipWith = \f (CoIndex as) (CoIndex bs) ->+ let+ !alen = QRA.wLength as+ !blen = QRA.wLength bs+ in+ case compare alen blen of+ EQ -> CoIndex $ QRA.zipWith f as bs+ GT {- alen > blen -}->+ CoIndex $ QRA.zipWith f (QRA.drop (alen - blen) as)+ bs+ LT {- alen < blen -} ->+ CoIndex $ QRA.zipWith f as+ (QRA.drop (blen - alen ) bs)+{-# INLINE (!!) #-}+(!!) :: RAList a -> Word64 -> a+rls !! n | n < 0 = error "Data.RAList.Flip.!!: negative index"+ | n >= (wLength rls) = error "Data.RAList.Flip.!!: index too large"+ | otherwise = reindex rls QRA.!! ((wLength rls) - 1 - n )+{-# INLINE lookupWithDefault #-}+lookupWithDefault :: forall t. t -> Word64 -> RAList t -> t+lookupWithDefault = \ def ix tree -> QRA.lookupWithDefault def ((wLength tree) - 1 - ix ) $ reindex tree+++{-# INLINE lookupM #-}+lookupM :: forall a m . MF.MonadFail m => Word64 -> RAList a -> m a+lookupM = \ ix tree -> QRA.lookupM (reindex tree) ((wLength tree) - 1 - ix)++{-# INLINE lookup #-}+lookup :: forall a. RAList a -> Word64 -> Maybe a+lookup = \ (CoIndex tree) ix -> QRA.lookup tree ((QRA.wLength tree) - 1 - ix )++{-# INLINE lookupCC #-}+lookupCC :: RAList a -> Word64 -> (a -> r) -> (String -> r) -> r+lookupCC = \ tree ix f g -> QRA.lookupCC (reindex tree) ((wLength tree) - 1 - ix ) f g++{-# INLINE wLength #-}+wLength:: RAList a -> Word64+wLength = \ (CoIndex ls) -> QRA.wLength ls++(++) :: RAList a -> RAList a -> RAList a+(++) = (<>)++++partition :: (a->Bool) -> RAList a -> (RAList a, RAList a)+partition = \ f ls -> (case QRA.partition f $ coerce ls of (la, lb ) -> (coerce la , coerce lb) )++filter :: forall a . (a -> Bool) -> RAList a -> RAList a+filter = \ f ls -> coerce $ QRA.filter f (coerce ls )+++catMaybes :: RAList (Maybe a) -> RAList a+catMaybes = \ls -> coerce $ (QRA.catMaybes $ (coerce :: RAList (Maybe a) -> QRA.RAList (Maybe a)) ls)+++wither :: forall a b f . (Applicative f) =>+ (a -> f (Maybe b)) -> RAList a -> f (RAList b)+wither = \f la -> coerceWith coerceThroughFunctor $ QRA.wither f $ coerce la+---+-- applicatives / functors can be coerced under, i have spoken+{-+for context, i otherwise need to do the following :+wither :: forall a b f . (Applicative f, (forall c d . Coercible c d => Coercible (f c) (f d)) ) =>+ (a -> f (Maybe b)) -> RAList a -> f (RAList b)+wither = \f la -> coerce $ QRA.wither f $ coerce la+-}+{-#INLINE coerceThroughFunctor #-}+coerceThroughFunctor :: forall a b f. (Coercible a b, Functor f) => (Coercion (f a) (f b))+coerceThroughFunctor = (unsafeCoerce (Coercion :: Coercion a b )) :: (Coercion (f a) (f b))++---++mapMaybe :: forall a b . (a -> Maybe b) -> RAList a -> RAList b+mapMaybe = \f la -> coerce $ QRA.mapMaybe f $ coerce la++genericLength :: forall a w . Integral w =>RAList a -> w+genericLength x = QRA.genericLength $ reindex x++genericTake :: forall a n . Integral n => n -> RAList a -> RAList a+genericTake i x = coerce $ QRA.genericTake i $ (coerce :: RAList a -> QRA.RAList a) x++genericDrop :: Integral n => n -> RAList a -> RAList a+genericDrop i x = coerce $ QRA.genericDrop i $ (coerce :: RAList a -> QRA.RAList a) x++genericSplitAt :: Integral n => n -> RAList a -> (RAList a, RAList a)+genericSplitAt i x = case QRA.genericSplitAt i $ reindex x of (a,b) -> (coerce a, coerce b)++genericIndex :: Integral n => RAList a -> n -> a+genericIndex x i = QRA.genericIndex (reindex x) i++genericReplicate :: Integral n => n -> a -> RAList a+genericReplicate i v = coerce $ QRA.genericReplicate i v+++update :: Word64 -> a -> RAList a -> RAList a+update i v l = adjust (const v) i l+++adjust :: forall a . (a->a) -> Word64 -> RAList a -> RAList a+adjust f i l = coerce $ QRA.adjust f ((wLength l) - 1 - i) $ coerce l+++unfoldr :: (b -> Maybe (a, b)) -> b -> RAList a+unfoldr f init = coerce $ QRA.unfoldr f init
+ src/Data/RAList/Internal.hs view
@@ -0,0 +1,19 @@+module Data.RAList.Internal where++import Data.Word+-- cribbed from indexed-traversable, modified+-- originally in 'Control.Lens.Indexed.indexed'.+newtype Indexing f a = Indexing { runIndexing :: Word64 -> (Word64, f a) }++instance Functor f => Functor (Indexing f) where+ fmap f (Indexing m) = Indexing $ \i -> case m i of+ (j, x) -> (j, fmap f x)+ {-# INLINE fmap #-}++instance Applicative f => Applicative (Indexing f) where+ pure x = Indexing $ \i -> (i, pure x)+ {-# INLINE pure #-}+ Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of+ (j, ff) -> case ma j of+ (k, fa) -> (k, ff <*> fa)+ {-# INLINE (<*>) #-}
tests/hspec.hs view
@@ -1,10 +1,23 @@ module Main where import Data.RAList+import qualified Data.RAList.Co as Co import Test.Hspec import Control.Exception (evaluate)+import Data.Word (Word64) +import Prelude hiding (+ (++), head, last, tail, init, null, length, map, reverse,+ foldl, foldl1, foldr, foldr1, concat, concatMap,+ and, or, any, all, sum, product, maximum, minimum, take,+ drop, elem, splitAt, notElem, lookup, replicate, (!!), filter,+ zip, zipWith, unzip+ )+import qualified Prelude +empty :: RAList a+empty = Nil+ main = hspec $ do describe "RAList.cons" $ do it "adds to an empty list" $ do@@ -90,6 +103,27 @@ it "returns 9 if the list has length 9" $ do Data.RAList.length (fromList [1..9]) `shouldBe` 9 + describe "Ralist.(!!)" $ do+ it "!! 0" $ do+ (fromList [ 1 .. 9]) !! 0 `shouldBe` 1+ it "!! 1" $ do+ (fromList [ 1 .. 9]) !! 1 `shouldBe` 2+ it "!! 2" $ do+ (fromList [ 1 .. 9]) !! 2 `shouldBe` 3+ it "!! 3" $ do+ (fromList [ 1 .. 9]) !! 3 `shouldBe` 4+ it "!! 4" $ do+ (fromList [ 1 .. 9]) !! 4 `shouldBe` 5+ it "!! 5" $ do+ (fromList [ 1 .. 9]) !! 5 `shouldBe` 6+ it "!! 6" $ do+ (fromList [ 1 .. 9]) !! 6 `shouldBe` 7+ it "!! 7" $ do+ (fromList [ 1 .. 9]) !! 7 `shouldBe` 8+ it "!! 8" $ do+ (fromList [ 1 .. 9]) !! 8 `shouldBe` 9++ describe "RAList.lookupL" $ do describe "for a list of length 1" $ do let ra = fromList [('a','b')]@@ -705,4 +739,119 @@ toList (fromList [1..9]) `shouldBe` ([1..9] :: [Int]) it "converts an empty list" $ do toList (empty) `shouldBe` ([] :: [Int])++ -- ═══════════════════════════════════════════════════════+ -- Data.RAList.Co tests (reversed indexing)+ -- ═══════════════════════════════════════════════════════++ let co3 = Co.fromList [1,2,3] :: Co.RAList Int+ co9 = Co.fromList [1..9] :: Co.RAList Int+ coEmpty = Co.Nil :: Co.RAList Int++ describe "Co.cons/uncons" $ do+ it "cons adds to an empty list" $+ Co.cons 1 coEmpty `shouldBe` Co.fromList [1 :: Int]+ it "cons then uncons roundtrips" $+ Co.uncons (Co.cons 42 co3) `shouldBe` Just (42 :: Int, co3)+ it "uncons empty is Nothing" $+ Co.uncons coEmpty `shouldBe` (Nothing :: Maybe (Int, Co.RAList Int))++ describe "Co.toList/fromList" $ do+ it "roundtrips length 3" $+ Co.toList co3 `shouldBe` [1,2,3 :: Int]+ it "roundtrips length 9" $+ Co.toList co9 `shouldBe` [1..9 :: Int]+ it "roundtrips empty" $+ Co.toList coEmpty `shouldBe` ([] :: [Int])++ describe "Co.(!!) reversed indexing" $ do+ -- Co indexes from the back: head is at (length-1), last is at 0+ it "!! 0 gives last element" $+ co9 Co.!! 0 `shouldBe` (9 :: Int)+ it "!! (length-1) gives first element" $+ co9 Co.!! 8 `shouldBe` (1 :: Int)+ it "!! 4 gives middle element" $+ co9 Co.!! 4 `shouldBe` (5 :: Int)++ describe "Co.lookup" $ do+ it "lookup 0 gives last" $+ Co.lookup co9 0 `shouldBe` Just (9 :: Int)+ it "lookup (length-1) gives first" $+ Co.lookup co9 8 `shouldBe` Just (1 :: Int)+ it "lookup out of bounds gives Nothing" $+ Co.lookup co9 99 `shouldBe` (Nothing :: Maybe Int)++ describe "Co.length" $ do+ it "length 9" $+ Co.wLength co9 `shouldBe` (9 :: Word64)+ it "length empty" $+ Co.wLength coEmpty `shouldBe` (0 :: Word64)++ describe "Co.drop" $ do+ it "drop 0 is identity" $+ Co.toList (Co.drop 0 co9) `shouldBe` [1..9 :: Int]+ it "drop 3 removes first 3" $+ Co.toList (Co.drop 3 co9) `shouldBe` [4..9 :: Int]+ it "drop all gives empty" $+ Co.toList (Co.drop 9 co9) `shouldBe` ([] :: [Int])++ describe "Co.take" $ do+ it "take 3 keeps first 3" $+ Co.toList (Co.take 3 co9) `shouldBe` [1,2,3 :: Int]+ it "take 0 gives empty" $+ Co.toList (Co.take 0 co9) `shouldBe` ([] :: [Int])+ it "take all is identity" $+ Co.toList (Co.take 9 co9) `shouldBe` [1..9 :: Int]++ describe "Co.zip/zipWith" $ do+ it "zip equal length" $+ Co.toList (Co.zip co3 (Co.fromList [10,20,30])) `shouldBe`+ [(1,10),(2,20),(3,30 :: Int)]+ it "zipWith (+) equal length" $+ Co.toList (Co.zipWith (+) co3 (Co.fromList [10,20,30])) `shouldBe`+ [11,22,33 :: Int]+ it "zip different lengths truncates from front (Co semantics)" $+ Co.toList (Co.zip co3 co9) `shouldBe`+ [(1,7),(2,8),(3,9 :: Int)]++ describe "Co.filter/partition" $ do+ it "filter even" $+ Co.toList (Co.filter even co9) `shouldBe` [2,4,6,8 :: Int]+ it "partition even" $ do+ let (evens, odds) = Co.partition even co9+ Co.toList evens `shouldBe` [2,4,6,8 :: Int]+ Co.toList odds `shouldBe` [1,3,5,7,9 :: Int]++ describe "Co.genericReplicate (was infinite recursion)" $ do+ it "replicate 0" $+ Co.toList (Co.genericReplicate (0 :: Int) 'x') `shouldBe` ""+ it "replicate 1" $+ Co.toList (Co.genericReplicate (1 :: Int) 'x') `shouldBe` "x"+ it "replicate 5" $+ Co.toList (Co.genericReplicate (5 :: Int) 'x') `shouldBe` "xxxxx"++ describe "Co.adjust (was infinite recursion)" $ do+ it "adjust at 0 modifies last element" $+ Co.toList (Co.adjust (+100) 0 co9) `shouldBe`+ [1,2,3,4,5,6,7,8,109 :: Int]+ it "adjust at (length-1) modifies first element" $+ Co.toList (Co.adjust (+100) 8 co9) `shouldBe`+ [101,2,3,4,5,6,7,8,9 :: Int]+ it "adjust at 4 modifies middle element" $+ Co.toList (Co.adjust (*10) 4 co9) `shouldBe`+ [1,2,3,4,50,6,7,8,9 :: Int]++ describe "Co.update (uses adjust)" $ do+ it "update at 0 replaces last element" $+ Co.toList (Co.update 0 99 co9) `shouldBe`+ [1,2,3,4,5,6,7,8,99 :: Int]+ it "update at 8 replaces first element" $+ Co.toList (Co.update 8 99 co9) `shouldBe`+ [99,2,3,4,5,6,7,8,9 :: Int]++ describe "Co.append" $ do+ it "append two lists" $+ Co.toList (co3 Co.++ Co.fromList [4,5,6]) `shouldBe` [1..6 :: Int]+ it "append empty" $+ Co.toList (co3 Co.++ coEmpty) `shouldBe` [1,2,3 :: Int]