{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, TypeFamilies #-} -- TypeFamilies is only used for equality constraints {- | Module : Data.Containers Description : Classes for different container types Copyright : Ivan Lazar Miljenovic License : 3-Clause BSD-style Maintainer : Ivan.Miljenovic@gmail.com -} module Data.Containers where import Prelude hiding ((!!), (++), elem, enumFrom, enumFromThen, enumFromTo, enumFromThenTo, all, and, any, break, concat, concatMap, cycle, drop, dropWhile, filter, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, lines, lookup, map, mapM, mapM_, maximum, minimum, notElem, null, or, product, repeat, replicate, reverse, scanl, scanl1, scanr, scanr1, sequence, sequence_, span, splitAt, sum, tail, take, takeWhile, unlines, unwords, unzip, unzip3, words, zip, zip3, zipWith, zipWith3, fmap) import qualified Prelude import Data.Char(isSpace) import qualified Data.List as List import Data.Maybe(fromMaybe) import Data.Monoid import Control.Monad(liftM2) infixl 9 !! infix 4 `elem`, `notElem` -- | 'Container's are data-types that store values. No restriction is -- placed on /how/ they store these values, though there may be -- restrictions on some methods if a 'Container' is also an instance -- of a sub-class of 'Container'. -- -- Minimum required implementation: -- -- * 'null' -- -- * 'insert' -- -- * 'fold' or 'splitElem' class (Monoid c) => Container c v | c -> v where -- | Test whether a 'Container' is empty. null :: c -> Bool -- | Create a singleton 'Container'; -- i.e. @'size' ('singleton' x) == 1@). singleton :: v -> c singleton v = build ($v) -- | Add a value to the 'Container'. If this is also a 'Sequence', -- then it should be a \"'cons'\" operation (i.e. insert the value -- at the beginning of the 'Sequence'). insert :: v -> c -> c -- | The container membership predicate, usually written in infix -- form, e.g., @v `elem` c@. elem :: (Eq v) => v -> c -> Bool elem = any . (==) -- | The negated version of 'elem'. notElem :: (Eq v) => v -> c -> Bool notElem v = not . elem v -- | Delete the first value of the 'Container' that matches the -- predicate. delete :: (Eq v) => v -> c -> c delete v = snd . fold delete' (False, empty) where delete' v' (False,c') | v' == v = (True, c') delete' v' (flag, c') = (flag, v' `insert` c') -- | Delete all values in the 'Container' that match the predicate. deleteAll :: (Eq v) => v -> c -> c deleteAll v = filter (/=v) -- | When applied to a predicate and a 'Container', 'filter' returns -- the 'Container' containing just those elements that satisfy the -- predicate (preserving order where applicable). filter :: (v -> Bool) -> c -> c filter p c = build (\ ins nil -> fold (\ v c' -> if p v then v `ins` c' else c') nil c ) -- | Applied to a binary operator, a starting value and a -- 'Container', reduce the 'Container' using the binary operator. -- For 'Sequence' instances, this should be a right fold. fold :: (v -> a -> a) -> a -> c -> a fold f s c = case splitElem c of Nothing -> s Just (v,c') -> f v $ fold f s c' -- | A variant of 'fold' with no starting value, and thus must be -- applied to non-empty 'Container's. fold1 :: (v -> v -> v) -> c -> v fold1 f = fromMaybe err . fold f' Nothing where err = error "Container.fold1: empty container" f' v Nothing = Just v f' v (Just v') = Just $ f v v' -- | Returns the size of the 'Container'. genericSize :: (Num n) => c -> n genericSize = fold (const (($!) (+1))) 0 -- | Returns the size of the 'Container' as an 'Int'. Typically -- more efficient than 'genericSize'. size :: c -> Int size = genericSize partition :: (v -> Bool) -> c -> (c,c) partition p = fold select (empty, empty) where select v ~(ts,fs) | p v = (v `insert` ts, fs) | otherwise = (ts, v `insert` fs) -- | Applied to a predicate and a 'Container', 'all' determines if -- all elements of the 'Container' satisfy the predicate. all :: (v -> Bool) -> c -> Bool all p = fold ((&&) . p) True -- | Returns the conjunction of a 'Container' containing Boolean -- values. For the result to be 'True', the 'Container' must be -- finite; 'False', however, results from a 'False' value -- occurring within a finite position within the order utilised by -- 'fold'. and :: (v ~ Bool) => c -> Bool and = fold (&&) True -- | Applied to a predicate and a 'Container', 'any' determines if -- any element of the 'Container' satisfies the predicate. any :: (v -> Bool) -> c -> Bool any p = fold ((||) . p) True -- | Returns the disjunction of a 'Container' containing Boolean -- values. For the result to be 'False', the 'Container' must be -- finite; 'True', however, results from a 'True' value -- occurring within a finite position within the order utilised by -- 'fold'. or :: (v ~ Bool) => c -> Bool or = fold (||) False -- | Computes the product of a finite 'Container' of numbers. product :: (Num v) => c -> v product = fold (*) 1 -- | Computes the sum of a finite 'Container' of numbers. sum :: (Num v) => c -> v sum = fold (+) 0 -- | A type-preserving mapping function, where the resulting -- 'Container' is obtained by applying the provided function on -- every element of the 'Container'. For instances of 'CFunctor', -- @'rigidMap' = 'map'@ suffices. rigidMap :: (v -> v) -> c -> c rigidMap f c = build (\ins nil -> fold (ins . f) nil c) -- | An inverse to 'insert'. Should obey the following: -- -- * @isNothing ('splitElem' c) == 'null' c@ -- -- * If @'splitElem' c = 'Just' (v,c')@, then @c == v `'insert'` c'@. -- -- * If @c@ is an instance of 'Sequence', then the returned value -- should be the first one. splitElem :: c -> Maybe (v, c) splitElem = fold getFirst Nothing where getFirst v Nothing = Just (v, empty) getFirst v (Just (v', c')) = Just (v', v `insert` c') -- | Returns the maximum value of a non-empty, finite 'Container'. maximum :: (Ord v) => c -> v maximum c | null c = error "Container.maximum: empty container" | otherwise = fold1 max c -- | Returns the minimum value of a non-empty, finite 'Container'. minimum :: (Ord v) => c -> v minimum c | null c = error "Container.minimum: empty container" | otherwise = fold1 min c build :: (Container c v) => ((v -> c -> c) -> c -> c) -> c build f = f insert empty -- | An alias for 'mempty'; constructs an empty 'Container'. empty :: (Container c v) => c empty = mempty -- | An alias for 'mappend'; combines two 'Container's. For instances -- of 'Sequence' this should be an @append@ operation. (++) :: (Container c v) => c -> c -> c (++) = mappend -- | Concatenate all the inner 'Container's together. concat :: (Container o i, Container i v) => o -> i concat = fold (++) empty -- | Map a function over a 'Container' and concatenate the results. -- Note that the types of the initial and final 'Container's do not -- have to be the same. concatMap :: (Container f fv, Container t tv) => (fv -> t) -> f -> t concatMap f c = build (\ ins nil -> fold ((++) . f) nil c) -- | Convert one 'Container' to another. If they are both -- 'Sequence's, then ordering is preserved. convertContainer :: (Container f v, Container t v) => f -> t convertContainer = convertContainerBy id -- | Convert one 'Container' to another by utilising a mapping -- function. If they are both 'Sequence's, then ordering is -- preserved. convertContainerBy :: (Container f fv, Container t tv) => (fv -> tv) -> f -> t convertContainerBy f c = build (\ ins nil -> fold (ins . f) nil c) -- | Denotes 'Container's that have kind @* -> *@ and can thus have -- more than one possible type of value stored within them. class (Container (c a) a) => CFunctor c a where -- | Apply the provided function on every element of the 'Container'. map :: (CFunctor c b) => (a -> b) -> c a -> c b map = convertContainerBy -- | Evaluate each action in the 'Container' and collect the results. -- The order the actions are evaluated in are determined by the -- corresponding 'fold' definition. sequence :: (Monad m, CFunctor c a, CFunctor c (m a)) => c (m a) -> m (c a) sequence = mapM id -- | Evaluate each action in the 'Container' and discard the results. -- The order the actions are evaluated in are determined by the -- corresponding 'fold' definition. sequence_ :: (Monad m, Container c (m a)) => c -> m () sequence_ = fold (>>) (return ()) -- Can't use "mapM_ id" as it requires an internal container and thus -- constrains the type more. -- | Apply the monadic mapping function to all the elements of the -- 'Container, and then evaluate the actions and collect the -- results. The order the actions are evaluated in are determined -- by the corresponding 'fold' definition. mapM :: (Monad m, CFunctor c a, CFunctor c b) => (a -> m b) -> c a -> m (c b) mapM f = fold (liftM2 insert . f) (return empty) -- By not using sequence, we remove the requirement of the extra internal constraint -- | Apply the monadic mapping function to all the elements of the -- 'Container, and then evaluate the actions and discard the -- results. The order the actions are evaluated in are determined -- by the corresponding 'fold' definition. mapM_ :: (Monad m, CFunctor c a) => (a -> m b) -> c a -> m () mapM_ f = fold ((>>) . f) (return ()) -- ----------------------------------------------------------------------------- -- | 'Sequence's are linear 'Container's with explicit left (start) -- and right (end) ends. As such, it is possible to append/traverse -- from either end. -- -- All methods have default stand-alone definitions, and thus no -- explicit method definitions are required for instances. class (Container c v) => Sequence c v where -- | Append the value to the end of the 'Sequence'. snoc :: c -> v -> c snoc c v = c ++ singleton v -- | Applied to a binary operator, a starting value and a -- 'Sequence', reduce the 'Sequence' using the binary operator -- from left to right. -- -- The default definition is modelled after 'Data.List.foldl'' -- rather than 'Data.List.foldl'. foldl :: (b -> v -> b) -> b -> c -> b foldl f s c = case viewL c of Nothing -> s Just (v,c') -> let s' = f s v in s' `seq` foldl f s' c' -- | A variant of 'foldl' with no starting value, and thus must be -- applied to non-empty 'Sequences's. foldl1 :: (v -> v -> v) -> c -> v foldl1 f = fromMaybe err . foldl f' Nothing where err = error "Sequence.foldl1: empty sequence" f' Nothing v = Just v f' (Just v') v = Just $ f v' v -- | An inverse to 'snoc' (equivalent to @('init' xs, 'last xs')@ -- for non-empty 'Sequence's). Should obey the following: -- -- * @isNothing ('viewR' xs) == 'null' xs@ -- -- * If @'viewR' xs = 'Just' (x,xs')@, then @xs == xs' `'snoc'` x@. viewR :: c -> Maybe (v, c) viewR = foldl getLast Nothing where getLast Nothing v = Just (v, empty) getLast (Just (v', c')) v = Just (v', c' `snoc` v) -- | The first element of a non-empty 'Sequence'. head :: (Sequence c v) => c -> v head = maybe err fst . viewL where err = error "Sequence.head: empty sequence" -- | Everything except the first element of a non-empty 'Sequence'. -- Consider instead using 'drop 1'. tail :: (Sequence c v) => c -> c tail = maybe err snd . viewL where err = error "Sequence.tail: empty sequence" -- | The last element of a non-empty 'Sequence'. last :: (Sequence c v) => c -> v last = maybe err fst . viewR where err = error "Sequence.last: empty sequence" -- | Everything except the last value of a non-empty 'Sequence'. init :: (Sequence c v) => c -> c init = maybe err snd . viewR where err = error "Sequence.init: empty sequence" -- | Return the first @n@ elements of a 'Sequence', or the entire -- 'Sequence' if its 'length' is less than @n@. genericTake :: (Integral n) => n -> c -> c genericTake l = go l . viewL where go n _ | n <= 0 = empty go _ Nothing = empty go n (Just(v,c')) = v `cons` go (n-1) (viewL c') -- | A variant of 'genericTake' where @n@ has to be an 'Int', and is -- usually more efficient. take :: Int -> c -> c take = genericTake -- | When applied to a predicate @p@ and a 'Sequence' @xs@, returns -- the longest prefix (possibly empty) of @xs@ of elements that -- satisfy @p@. takeWhile :: (v -> Bool) -> c -> c takeWhile p = go . viewL where go Nothing = empty go (Just(v,c)) | p v = v `cons` go (viewL c) | otherwise = empty -- | @'dropWhile' p xs@ returns the suffix remaining after -- @'takeWhile' p xs@. dropWhile :: (v -> Bool) -> c -> c dropWhile p c = build (go (viewL c)) where go Nothing _ nil = nil go (Just(v,c)) ins nil | p v = go (viewL c) ins nil | otherwise = v `ins` c -- | @'genericDrop' n xs@ returns the suffix of @xs@ after the first -- @n@ elements, or 'empty' if @n > 'length' xs@. genericDrop :: (Integral n) => n -> c -> c genericDrop l c = build (go l (viewL c)) where go _ Nothing _ nil = nil go n (Just(_,c)) ins nil | n <= 0 = nil | otherwise = go (n-1) (viewL c) ins nil -- | A variant of 'genericDrop' where @n@ has to be an 'Int', and is -- usually more efficient. drop :: Int -> c -> c drop = genericDrop -- | @'reverse' xs@ returns the elements of @xs@ in reverse order. -- @xs@ must be finite. reverse :: c -> c reverse c = build (\ ins nil -> foldl (flip ins) nil c) -- | When applied to a predicate @p@ and a 'Sequence' @xs@, returns -- a tuple where first element is longest prefix (possibly empty) -- of @xs@ of elements that satisfy p and second element is the -- remainder of the 'Sequence'. span :: (v -> Bool) -> c -> (c,c) span p = go . viewL where go Nothing = (empty, empty) go (Just(v,c)) | p v = let (t,f) = go (viewL c) in (v `cons` t, f) | otherwise = (empty, v `cons` c) -- | When applied to a predicate @p@ and a 'Sequence' @xs@, returns -- a tuple where first element is longest prefix (possibly empty) -- of @xs@ of elements that /do not satisfy/ p and second element -- is the remainder of the 'Sequence'. -- -- @'break' p@ is equivalent to @'span' ('not' . p)@. break :: (v -> Bool) -> c -> (c,c) break = span . (not .) -- | @'genericSplitAt' n xs@ returns a tuple where the first element -- is the prefix of 'length' @n@ of @xs@ and the second element is -- the rest of the 'Sequence'. It is equivalent to -- @('genericTake' n xs, 'genericDrop' n xs)@. genericSplitAt :: (Integral n) => n -> c -> (c,c) genericSplitAt n c = (genericTake n c, genericDrop n c) -- | A variant of 'genericSplitAt' where @n@ has to be an 'Int', and -- is usually more efficient. splitAt :: Int -> c -> (c,c) splitAt n c = (take n c, drop n c) -- | @'genericReplicate' n x@ is a 'Sequence' of length @n@ where -- every element is @x@. genericReplicate :: (Integral n) => n -> v -> c genericReplicate l v = build (go l) where go n _ nil | n <= 0 = nil go n ins nil = v `ins` go (n-1) ins nil -- | A variant of 'genericReplicate' where @n@ has to be an 'Int', -- and is usually more efficient. replicate :: Int -> v -> c replicate = genericReplicate -- | 'lines' breaks a string up into a 'Sequence' of 'Strings' at -- newline characters. The resulting 'Strings' do not contain -- newlines. lines :: (v ~ String) => String -> c lines = build . go where go "" _ nil = nil go s ins nil = let (l, s') = Prelude.break (== '\n') s in l `ins` case s' of "" -> nil (_:s'') -> go s'' ins nil -- | 'unlines' is an inverse operation to 'lines'. It joins lines, -- after appending a terminating newline to each. unlines :: (v ~ String) => c -> String unlines = go . viewL where go Nothing = "" go (Just(l,ls)) = l Prelude.++ '\n' : go (viewL ls) -- | 'words' breaks a 'String' up into a 'Sequence' of words, which -- were delimited by white space. words :: (v ~ String) => String -> c words = build . go where go s ins nil = case Prelude.dropWhile isSpace s of "" -> nil s' -> let (w,s'') = Prelude.break isSpace s' in w `ins` go s'' ins nil -- | 'unwords' is an inverse operation to 'words'. It joins words -- with separating spaces. unwords :: (v ~ String) => c -> String unwords = go . viewL where go Nothing = "" go (Just(fw,ws)) = go' fw $ viewL ws where go' w Nothing = w go' w (Just(w',ws')) = w Prelude.++ ' ' : go' w' (viewL ws') buildL :: (Sequence c v) => ((c -> v -> c) -> c -> c) -> c buildL f = f snoc empty -- | An alias for 'insert' for 'Sequence's. cons :: (Sequence c v) => v -> c -> c cons = insert -- | An alias for 'genericSize' for 'Sequence's. genericLength :: (Sequence c v, Integral n) => c -> n genericLength = genericSize -- | An alias for 'size' for 'Sequence's. length :: (Sequence c v) => c -> Int length = size -- | An alias for 'fold' for 'Seuquence's. foldr :: (Sequence c v) => (v -> a -> a) -> a -> c -> a foldr = fold -- | An alias for 'fold1' for 'Seuquence's. foldr1 :: (Sequence c v) => (v -> v -> v) -> c -> v foldr1 = fold1 -- | An alias for 'splitElem' for 'Seuquence's. viewL :: (Sequence c v) => c -> Maybe (v,c) viewL = splitElem -- | 'Sequence' index (subscript) operator, starting from 0. Will -- throw an 'error' if the index is negative or larger than the -- length of the 'Sequence'. (!!) :: (Sequence c v) => c -> Int -> v _ !! n | n < 0 = error "Sequence.(!!): negative index" c !! n = maybe err fst . viewL $ drop (n-1) c where err = error "Sequence.(!!): index too large" -- | Represents 'Sequence's that are also instances of 'CFunctor'. -- All methods have default definitions. class (Sequence (c a) a, CFunctor c a) => SFunctor c a where scanl :: (SFunctor c b) => (b -> a -> b) -> b -> c a -> c b scanl f b = build . go b where go v c ins nil = v `ins` case viewL c of Nothing -> nil Just (v',c') -> go (f v v') c ins nil scanl1 :: (a -> a -> a) -> c a -> c a scanl1 f = maybe (build (const id)) (uncurry (scanl f)) . viewL scanr :: (SFunctor c b) => (a -> b -> b) -> b -> c a -> c b scanr f b = build . go . viewL where go Nothing _ _ = singleton b go (Just(v,c)) ins nil = f v (head c') `ins` c' where c' = go (viewL c) ins nil scanr1 :: (a -> a -> a) -> c a -> c a scanr1 f = maybe (build (const id)) (uncurry (scanr f)) . viewL zipWith :: (SFunctor c b, SFunctor c d) => (a -> b -> d) -> c a -> c b -> c d zipWith f ca cb = build $ wrap ca cb where wrap ca' cb' = go (viewL ca') (viewL cb') go (Just(a,ca')) (Just(b,cb')) ins nil = f a b `ins` wrap ca' cb' ins nil go _ _ _ nil = nil zip :: (SFunctor c b, SFunctor c (a,b)) => c a -> c b -> c (a,b) zip = zipWith (,) unzip :: (SFunctor c b, SFunctor c (a,b)) => c (a,b) -> (c a, c b) unzip = fold f (empty,empty) where f (a,b) ~(ca,cb) = (a `cons` ca, b `cons` cb) zipWith3 :: (SFunctor c b, SFunctor c d, SFunctor c e) => (a -> b -> d -> e) -> c a -> c b -> c d -> c e zipWith3 f ca cb cd = build $ wrap ca cb cd where wrap ca' cb' cd' = go (viewL ca') (viewL cb') (viewL cd') go (Just(a,ca')) (Just(b,cb')) (Just(d,cd')) ins nil = f a b d `ins` wrap ca' cb' cd' ins nil go _ _ _ _ nil = nil zip3 :: (SFunctor c b, SFunctor c d, SFunctor c (a,b,d)) => c a -> c b -> c d -> c (a,b,d) zip3 = zipWith3 (,,) unzip3 :: (SFunctor c b, SFunctor c d, SFunctor c (a,b,d)) => c (a,b,d) -> (c a, c b, c d) unzip3 = fold f (empty,empty,empty) where f (a,b,d) ~(ca,cb,cd) = (a `cons` ca, b `cons` cb, d `cons` cd) -- ----------------------------------------------------------------------------- -- | Represents 'Sequence's that may be infinite in length. All -- methods have default definitions. class (Sequence c v) => Stream c v where -- | @'repeat' x@ is an infinite 'Stream', with @x@ the value of -- every element. repeat :: v -> c repeat v = v `cons` repeat v -- | 'cycle' ties a finite 'Stream' into a circular one, or -- equivalently, the infinite repetition of the original 'Stream'. -- It is the identity on infinite 'Stream's. cycle :: c -> c cycle = checkNull where checkNull c | null c = error "Stream.cycle: empty stream" | otherwise = go c go c = c ++ go c -- | @'iterate' f x@ returns an infinite 'Stream' of repeated -- applications of @f@ to @x@: -- -- > iterate f x = x `cons` f x `cons` f (f x) `cons` ... iterate :: (v -> v) -> v -> c iterate f = build . go where go x ins nil = x `ins` go (f x) ins nil -- | A wrapper around 'Prelude.enumFrom'. enumFrom :: (Enum a, Stream c a) => a -> c enumFrom = convertContainer . Prelude.enumFrom -- | A wrapper around 'Prelude.enumFromThen'. enumFromThen :: (Enum a, Stream c a) => a -> a -> c enumFromThen f th = convertContainer $ Prelude.enumFromThen f th -- | A wrapper around 'Prelude.enumFromThenTo'. enumFromThenTo :: (Enum a, Sequence c a) => a -> a -> a -> c enumFromThenTo f th t = convertContainer $ Prelude.enumFromThenTo f th t -- | A wrapper around 'Prelude.enumFromTo'. enumFromTo :: (Enum a, Sequence c a) => a -> a -> c enumFromTo f t = convertContainer $ Prelude.enumFromTo f t -- ----------------------------------------------------------------------------- instance Container [a] a where null = Prelude.null -- Use default to have build be used -- singleton = (:[]) insert = (:) elem = Prelude.elem notElem = Prelude.notElem delete = List.delete -- No pre-defined deleteAll equivalent filter = Prelude.filter fold = Prelude.foldr fold1 = Prelude.foldr1 genericSize = List.genericLength size = Prelude.length partition = List.partition all = Prelude.all and = Prelude.and any = Prelude.any or = Prelude.or product = Prelude.product sum = Prelude.sum rigidMap = map splitElem [] = Nothing splitElem (a:as) = Just (a,as) maximum = Prelude.maximum minimum = Prelude.minimum instance CFunctor [] a where map = Prelude.map instance Sequence [a] a where -- snoc can stay as is foldl = List.foldl' foldl1 = List.foldl1' -- Get the laziness into it viewR [] = Nothing viewR as = Just (last as, init as) head = Prelude.head tail = Prelude.tail last = Prelude.last init = Prelude.init genericTake = List.genericTake take = Prelude.take takeWhile = Prelude.takeWhile dropWhile = Prelude.dropWhile genericDrop = List.genericDrop drop = Prelude.drop reverse = Prelude.reverse span = Prelude.span break = Prelude.break genericSplitAt = List.genericSplitAt splitAt = Prelude.splitAt genericReplicate = List.genericReplicate replicate = Prelude.replicate lines = Prelude.lines unlines = Prelude.unlines words = Prelude.words unwords = Prelude.unwords instance SFunctor [] a where scanl = Prelude.scanl scanl1 = Prelude.scanl1 scanr = Prelude.scanr scanr1 = Prelude.scanr1 zip = Prelude.zip zipWith = Prelude.zipWith unzip = Prelude.unzip zip3 = Prelude.zip3 zipWith3 = Prelude.zipWith3 unzip3 = Prelude.unzip3