diff --git a/Data/RAList.hs b/Data/RAList.hs deleted file mode 100644 --- a/Data/RAList.hs +++ /dev/null @@ -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") diff --git a/benchmark/benchmarking.hs b/benchmark/benchmarking.hs --- a/benchmark/benchmarking.hs +++ b/benchmark/benchmarking.hs @@ -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 + ] ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/ralist.cabal b/ralist.cabal --- a/ralist.cabal +++ b/ralist.cabal @@ -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 diff --git a/src/Data/RAList.hs b/src/Data/RAList.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList.hs @@ -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) + +-} diff --git a/src/Data/RAList/Co.hs b/src/Data/RAList/Co.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Co.hs @@ -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 diff --git a/src/Data/RAList/Internal.hs b/src/Data/RAList/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Internal.hs @@ -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 (<*>) #-} diff --git a/tests/hspec.hs b/tests/hspec.hs --- a/tests/hspec.hs +++ b/tests/hspec.hs @@ -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]