{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable #-}
module Data.Sequence.NonEmpty where
import Control.Monad (join, ap)
import Data.Data (Data)
import Data.Semigroup (Semigroup((<>)))
import Data.Sequence (Seq, (<|), ViewL(EmptyL, (:<)), viewl)
import Data.Typeable (Typeable)
import qualified Data.Sequence as Seq
data NonEmptySeq a = NonEmptySeq
{ _fore :: a
, _aft :: Seq a
} deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)
fore :: Functor f => (a -> f a) -> NonEmptySeq a -> f (NonEmptySeq a)
fore inj (NonEmptySeq a1 as) = flip NonEmptySeq as <$> inj a1
aft :: Functor f => (Seq a -> f (Seq a)) -> NonEmptySeq a -> f (NonEmptySeq a)
aft inj (NonEmptySeq a1 as) = NonEmptySeq a1 <$> inj as
instance Semigroup (NonEmptySeq a) where
(NonEmptySeq a1 as) <> (NonEmptySeq b1 bs)
= NonEmptySeq a1 (as <> (b1 <| bs))
instance Monad NonEmptySeq where
return a = NonEmptySeq a Seq.empty
NonEmptySeq a as >>= f = NonEmptySeq (_fore r1) rs
where
r1 = f a
rs = _aft r1 `mappend` rss
rss = join . fmap nonEmptySeqToSeq . fmap f $ as
instance Applicative NonEmptySeq where
pure = return
(<*>) = ap
nonEmptySeqToSeq :: NonEmptySeq a -> Seq a
nonEmptySeqToSeq (NonEmptySeq a1 as) = a1 <| as
seqToNonEmptySeq :: Seq a -> Maybe (NonEmptySeq a)
seqToNonEmptySeq sq = case viewl sq of
EmptyL -> Nothing
x :< xs -> Just (NonEmptySeq x xs)
prependSeq :: Seq a -> NonEmptySeq a -> NonEmptySeq a
prependSeq sq (NonEmptySeq a as) = case viewl sq of
EmptyL -> NonEmptySeq a as
l :< ls -> NonEmptySeq l (ls `mappend` (a <| as))
appendSeq :: NonEmptySeq a -> Seq a -> NonEmptySeq a
appendSeq (NonEmptySeq a as) sq = NonEmptySeq a (as `mappend` sq)
singleton :: a -> NonEmptySeq a
singleton a = NonEmptySeq a Seq.empty