{-# 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
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"
-- XXX Make this a good producer
-- | Complexity /O(n)/.
--toList :: RAList a -> [a]
--toList = foldr (:) []
--toList ra = tops ra []
-- where flat (Leaf x) a = x : a
-- flat (Node x l r) a = x : flat l (flat r a)
-- tops RNil r = r
-- tops (RCons _tot _ 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 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)
-}