NonEmpty as a newtype and prism using AsEmpty

NonEmpty.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module NonEmpty where

import Control.Lens
import Control.Lens.Extras
import qualified Data.List.NonEmpty as NE
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Storable as S
import qualified Data.Vector.Unboxed as U
import Data.Serialize
import Data.Semigroup
import Control.DeepSeq

newtype NonEmpty v a =
  NonEmpty (v a)
  deriving (Eq,Show,Ord,Serialize,Functor,Foldable,Traversable,Applicative,Monad,Semigroup,NFData)

instance FunctorWithIndex i v => FunctorWithIndex i (NonEmpty v) where
  imap f (NonEmpty v) = NonEmpty (imap f v)

instance FoldableWithIndex i v => FoldableWithIndex i (NonEmpty v) where
  ifoldMap f (NonEmpty v) = ifoldMap f v

instance TraversableWithIndex i v => TraversableWithIndex i (NonEmpty v) where
  itraverse f (NonEmpty v) =
    NonEmpty <$>
    (itraverse f v)
    
_NonEmpty :: AsEmpty (v a) => Prism' (v a) (NonEmpty v a)
_NonEmpty = prism (\(NonEmpty va) -> va)
                  (\va -> case is _Empty va of
                            True -> Left va
                            False -> Right (NonEmpty va))
{-# INLINE _NonEmpty #-}

-- | NonEmpty Vector aliases

type NEVector = NonEmpty V.Vector
type NEUVector = NonEmpty U.Vector
type NESVector = NonEmpty S.Vector

-- | Stuff

nonEmptyHead :: Simple Cons (v a) a => NonEmpty v a -> a
nonEmptyHead (NonEmpty v) = v ^?! _head
{-# INLINE nonEmptyHead #-}

_VectorNEList :: G.Vector v a => Iso' (NonEmpty v a) (NE.NonEmpty a)
_VectorNEList = iso asTrueNonEmpty (NonEmpty . G.fromList . NE.toList)
{-# INLINE _NEList #-}

asTrueNonEmpty :: G.Vector v a => NonEmpty v a -> NE.NonEmpty a
asTrueNonEmpty (NonEmpty v) = NE.fromList . G.toList $ v

-- TODO orphan
instance Semigroup (V.Vector a) where
    (<>) = (V.++)
    {-# INLINE (<>) #-}