module Data.CappedList
( CappedList (..)
, null
, append
, map
, mapEither
, concatMap
, foldr
, foldl
, unfoldr
, length
) where
import Prelude hiding (null, map, concatMap, foldl, foldr, length)
import qualified Prelude as Prelude
import Data.Monoid (Monoid, mempty, mappend)
import Control.Monad (MonadPlus, mzero, mplus, ap)
import Control.Monad.Fix (MonadFix, fix, mfix)
import qualified Control.Applicative as A
import Control.Applicative ((<$>), (<*>))
import Data.Empty (Empty (empty))
import qualified Data.Foldable as F
import qualified Data.Traversable as T
data CappedList cap a
= Next a (CappedList cap a)
| Cap cap
deriving (Eq, Show)
instance Empty cap => Empty (CappedList cap a) where
empty = Cap empty
instance Functor (CappedList cap) where
fmap = map
instance Empty cap => Monoid (CappedList cap a) where
mempty = Cap empty
mappend = append
instance Empty cap => Monad (CappedList cap) where
Cap x >>= _ = Cap x
(Next x xs) >>= k = append (k x) (xs >>= k)
return = flip Next (Cap empty)
instance Empty cap => MonadPlus (CappedList cap) where
mzero = Cap empty
mplus = append
instance Empty cap => A.Alternative (CappedList cap) where
empty = Cap empty
(<|>) = append
instance Empty cap => A.Applicative (CappedList cap) where
pure = flip Next (Cap empty)
(<*>) = ap
instance F.Foldable (CappedList cap) where
foldMap = T.foldMapDefault
instance T.Traversable (CappedList cap) where
sequenceA (Cap x) = A.pure $ Cap x
sequenceA (Next f fs) = Next <$> f <*> T.sequenceA fs
instance Empty cap => MonadFix (CappedList cap) where
mfix f = case fix (f . head') of
Cap x -> Cap x
(Next x _) -> append (return x) (mfix (tail' . f))
null :: CappedList cap a -> Bool
null (Next _ _) = False
null _ = True
append :: CappedList cap a -> CappedList cap a -> CappedList cap a
append x@(Cap _) _ = x
append (Next x xs) y = Next x (append xs y)
map :: (a -> b) -> CappedList cap a -> CappedList cap b
map f = foldr (Next . f) Cap
mapEither :: (a -> Either cap b) -> CappedList cap a -> CappedList cap b
mapEither f = foldr (\a acc -> either Cap (flip Next acc) (f a)) Cap
concatMap :: (a -> CappedList cap b) -> CappedList cap a -> CappedList cap b
concatMap f = foldr (append . f) Cap
foldr :: (a -> b -> b) -> (cap -> b) -> CappedList cap a -> b
foldr f z = foldr' where
foldr' (Cap x) = z x
foldr' (Next x xs) = f x (foldr' xs)
foldl :: (b -> a -> b) -> (cap -> b) -> CappedList cap a -> b
foldl f = foldl' where
foldl' z (Cap x) = z x
foldl' z (Next x xs) = foldl' (\cap -> f (z cap) x) xs
unfoldr :: (b -> Either cap (a, b)) -> b -> CappedList cap a
unfoldr f = unfoldr' where
unfoldr' x = case f x of
Left cap -> Cap cap
Right (a, b) -> Next a (unfoldr' b)
length :: CappedList cap a -> Int
length = foldr (const (1 +)) (const 0)
head' :: CappedList cap a -> a
head' (Cap _) = error "mfix CappedList: Cap"
head' (Next x _) = x
tail' :: CappedList cap a -> CappedList cap a
tail' (Cap _) = error "mfix CappedList: Cap"
tail' (Next _ xs) = xs