```{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable #-}

-- | A 'Seq' that must contain at least one item.
module Data.Sequence.NonEmpty where

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

-- | Conceptually this is a 'Seq' that always contains at least one item.
data NonEmptySeq a = NonEmptySeq
{ _fore :: a
, _aft :: Seq a
} deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)

-- | van Laarhoven lens for the first element
fore :: Functor f => (a -> f a) -> NonEmptySeq a -> f (NonEmptySeq a)
fore inj (NonEmptySeq a1 as) = flip NonEmptySeq as <\$> inj a1

-- | van Laarhoven lens for the remaining elements
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))

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

-- | Flattens a 'NonEmptySeq' to a 'Seq'.
nonEmptySeqToSeq :: NonEmptySeq a -> Seq a
nonEmptySeqToSeq (NonEmptySeq a1 as) = a1 <| as

-- | If the 'Seq' has at least one item, create a 'NonEmptySeq'.
seqToNonEmptySeq :: Seq a -> Maybe (NonEmptySeq a)
seqToNonEmptySeq sq = case viewl sq of
EmptyL -> Nothing
x :< xs -> Just (NonEmptySeq x xs)

-- | Prepends a 'Seq' to a 'NonEmptySeq'.
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))

-- | Appends a 'Seq' to a 'NonEmptySeq'.
appendSeq :: NonEmptySeq a -> Seq a -> NonEmptySeq a
appendSeq (NonEmptySeq a as) sq = NonEmptySeq a (as `mappend` sq)

-- | Place a single item at the head of the 'NonEmptySeq'.
singleton :: a -> NonEmptySeq a
singleton a = NonEmptySeq a Seq.empty
```