{-| This package extends @NonEmpty@ from @semigroups@ to arbitrary
@Alternative@ types. The method is the same as for lists, by
separating an element from the rest.
There are two natural ways to merge an element @x@ to the rest of the
structure @xs@. The first gives rise to @NonEmptyL@:
> flattenL :: NonEmptyL f a -> f a
> flattenL (x :<: xs) = pure x <|> xs
The second gives rise to @NonEmptyR@:
> flattenR :: NonEmptyR f a -> f a
> flattenR (xs :>: x) = xs <|> pure x
The instances are made so that @flattenL@ gives a type class morphism
between @NonEmptyL List@ and @List@, and @flattenR@ gives the same for
@NonEmptyR RList@ and @RList@ from the package @rlist@.
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.NonEmpty
(
-- * Left Non-Empty Alternatives
NonEmptyL (..)
-- * Basic functions for `NonEmptyL`
, headL
, tailL
, flattenL
, joinL
, budgeL
-- * Right Non-Empty Alternatives
, NonEmptyR (..)
-- * Basic functions for `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
----------------------------------------------------------------------
-- | The type @NonEmptyL@ is well suited for `cons` structures.
data NonEmptyL f a = a :<: f a
deriving (Show, Eq, Ord,Read, Data, Typeable, Generic, Generic1)
infixr 5 :<:
-- | The type @NonEmptyR@ is well suited for `snoc` structures.
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
----------------------------------------------------------------------
-- | Extracts the structure's singular element. This function is total
-- and equivalent to @extract@ from @Comonad@.
headL :: NonEmptyL f a -> a
headL (x :<: _) = x
-- | Extracts the structure's remaining data. This function is total.
tailL :: NonEmptyL f a -> f a
tailL (_ :<: xs) = xs
-- | Flattens the structure to its base type from the left.
flattenL :: Alternative f => NonEmptyL f a -> f a
flattenL (x :<: xs) = pure x <|> xs
-- | This is equivalent to @join@ for @Monad@.
joinL :: (Alternative f, Monad f)
=> NonEmptyL f (NonEmptyL f a) -> NonEmptyL f a
joinL ((x :<: xs) :<: ys) = x :<: (xs <|> (ys >>= flattenL))
-- | Budge the head into the remaining structure from the left, adding
-- an empty head.
budgeL :: (Alternative f, Alternative g)
=> NonEmptyL f (g a) -> NonEmptyL f (g a)
budgeL = (empty :<:) . flattenL
----------------------------------------------------------------------
-- | Extracts the structure's singular element. This function is total
-- and equivalent to @extract@ from @Comonad@.
lastR :: NonEmptyR f a -> a
lastR (_ :>: x) = x
-- | Extracts the structure's remaining data. This function is total.
initR :: NonEmptyR f a -> f a
initR (xs :>: _) = xs
-- | Flattens the structure to its base type from the right.
flattenR :: Alternative f => NonEmptyR f a -> f a
flattenR (xs :>: x) = xs <|> pure x
-- | This is equivalent to @join@ for @Monad@.
joinR :: (Alternative f, Monad f)
=> NonEmptyR f (NonEmptyR f a) -> NonEmptyR f a
joinR (ys :>: (xs :>: x)) = ((ys >>= flattenR) <|> xs) :>: x
-- | Budge the head into the remaining structure from the right,
-- adding an empty head.
budgeR :: (Alternative f, Alternative g)
=> NonEmptyR f (g a) -> NonEmptyR f (g a)
budgeR = (:>: empty) . flattenR