module Data.NonEmpty
(
NonEmptyL (..)
, headL
, tailL
, flattenL
, joinL
, budgeL
, NonEmptyR (..)
, lastR
, initR
, flattenR
, joinR
, budgeR
) where
import Prelude hiding (head, tail)
import Data.Data
import GHC.Generics
import Data.Foldable
import Data.Semigroup
import Control.Applicative
import Control.Comonad
data NonEmptyL f a = a :<: f a
deriving (Show, Eq, Ord,Read, Data, Typeable, Generic, Generic1)
infixr 5 :<:
data NonEmptyR f a = f a :>: a
deriving (Show, Eq, Ord,Read, Data, Typeable, Generic, Generic1)
infixl 5 :>:
instance Functor f => Functor (NonEmptyL f) where
fmap f (x :<: xs) = (f x) :<: (f <$> xs)
instance Functor f => Functor (NonEmptyR f) where
fmap f (xs :>: x) = (f <$> xs) :>: (f x)
instance Alternative f => Applicative (NonEmptyL f) where
pure x = x :<: empty
(f :<: fs) <*> (x :<: xs) = (f x) :<: ( (pure f <*> xs )
<|> (fs <*> (pure x <|> xs)))
instance Alternative f => Applicative (NonEmptyR f) where
pure x = empty :>: x
(fs :>: f) <*> (xs :>: x) = ( (fs <*> (xs <|> pure x) )
<|> (pure f <*> xs ) ) :>: (f x)
instance (Alternative f, Monad f) => Monad (NonEmptyL f) where
(x :<: xs) >>= f = y :<: (ys <|> zs)
where (y :<: ys) = f x
zs = xs >>= flattenL . f
instance Alternative f => Comonad (NonEmptyL f) where
extract = headL
duplicate (x :<: xs) = (x :<: xs) :<: (fmap (:<: empty) xs)
instance Alternative f => Comonad (NonEmptyR f) where
extract = lastR
duplicate (xs :>: x) = (fmap (empty :>:) xs) :>: (xs :>: x)
instance Foldable f => Foldable (NonEmptyL f) where
foldr f z (x :<: xs) = f x (foldr f z xs)
foldr' f z (x :<: xs) = f x (foldr' f z xs)
foldr1 f (x :<: xs) = if null xs
then x
else f x (foldr1 f xs)
foldl f z (x :<: xs) = foldl f (f z x) xs
foldl' f z (x :<: xs) = foldl' f (f z x) xs
foldl1 f (x :<: xs) = foldl f x xs
instance Foldable f => Foldable (NonEmptyR f) where
foldr f z (xs :>: x) = foldr f (f x z) xs
foldr' f z (xs :>: x) = foldr' f (f x z) xs
foldr1 f (xs :>: x) = foldr f x xs
foldl f z (xs :>: x) = f (foldl f z xs) x
foldl' f z (xs :>: x) = f (foldl' f z xs) x
foldl1 f (xs :>: x) = if null xs
then x
else f (foldl1 f xs) x
instance (Functor f, Traversable f) => Traversable (NonEmptyL f) where
traverse f (x :<: xs) = (:<:) <$> f x
<*> traverse f xs
instance (Functor f, Traversable f) => Traversable (NonEmptyR f) where
traverse f (xs :>: x) = (:>:) <$> traverse f xs
<*> f x
instance Alternative f => Semigroup (NonEmptyL f a) where
(x :<: xs) <> (y :<: ys) = x :<: (xs <|> pure y <|> ys)
instance Alternative f => Semigroup (NonEmptyR f a) where
(xs :>: x) <> (ys :>: y) = (xs <|> pure x <|> ys) :>: y
headL :: NonEmptyL f a -> a
headL (x :<: _) = x
tailL :: NonEmptyL f a -> f a
tailL (_ :<: xs) = xs
flattenL :: Alternative f => NonEmptyL f a -> f a
flattenL (x :<: xs) = pure x <|> xs
joinL :: (Alternative f, Monad f)
=> NonEmptyL f (NonEmptyL f a) -> NonEmptyL f a
joinL ((x :<: xs) :<: ys) = x :<: (xs <|> (ys >>= flattenL))
budgeL :: (Alternative f, Alternative g)
=> NonEmptyL f (g a) -> NonEmptyL f (g a)
budgeL = (empty :<:) . flattenL
lastR :: NonEmptyR f a -> a
lastR (_ :>: x) = x
initR :: NonEmptyR f a -> f a
initR (xs :>: _) = xs
flattenR :: Alternative f => NonEmptyR f a -> f a
flattenR (xs :>: x) = xs <|> pure x
joinR :: (Alternative f, Monad f)
=> NonEmptyR f (NonEmptyR f a) -> NonEmptyR f a
joinR (ys :>: (xs :>: x)) = ((ys >>= flattenR) <|> xs) :>: x
budgeR :: (Alternative f, Alternative g)
=> NonEmptyR f (g a) -> NonEmptyR f (g a)
budgeR = (:>: empty) . flattenR