{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
#endif
module Control.Lens.Cons
(
Cons(..)
, (<|)
, cons
, uncons
, _head, _tail
#if __GLASGOW_HASKELL__ >= 710
, pattern (:>)
#endif
, Snoc(..)
, (|>)
, snoc
, unsnoc
, _init, _last
#if __GLASGOW_HASKELL__ >= 710
, pattern (:<)
#endif
) where
import Control.Lens.Equality (simply)
import Control.Lens.Fold
import Control.Lens.Prism
import Control.Lens.Review
import Control.Lens.Tuple
import Control.Lens.Type
import qualified Data.ByteString as StrictB
import qualified Data.ByteString.Lazy as LazyB
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Monoid
import qualified Data.Sequence as Seq
import Data.Sequence hiding ((<|), (|>), (:<), (:>))
import qualified Data.Text as StrictT
import qualified Data.Text.Lazy as LazyT
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Vector.Storable (Storable)
import qualified Data.Vector.Storable as Storable
import Data.Vector.Primitive (Prim)
import qualified Data.Vector.Primitive as Prim
import Data.Vector.Unboxed (Unbox)
import qualified Data.Vector.Unboxed as Unbox
import Data.Word
import Prelude
{-# ANN module "HLint: ignore Eta reduce" #-}
infixr 5 <|, `cons`
infixl 5 |>, `snoc`
#if __GLASGOW_HASKELL__ >= 710
pattern (:<) a s <- (preview _Cons -> Just (a,s)) where
(:<) a s = _Cons # (a,s)
infixr 5 :<
infixl 5 :>
pattern (:>) s a <- (preview _Snoc -> Just (s,a)) where
(:>) a s = _Snoc # (a,s)
#endif
class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where
_Cons :: Prism s t (a,s) (b,t)
instance Cons [a] [b] a b where
_Cons = prism (uncurry (:)) $ \ aas -> case aas of
(a:as) -> Right (a, as)
[] -> Left []
{-# INLINE _Cons #-}
instance a~b => Cons (NonEmpty a) (NonEmpty b) a b where
_Cons = prism' (uncurry NonEmpty.cons) $ \ xyz -> case xyz of
(x:|y:z) -> Just (x,y:|z)
_ -> Nothing
{-# INLINE _Cons #-}
instance Cons (Seq a) (Seq b) a b where
_Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of
a Seq.:< as -> Right (a, as)
EmptyL -> Left mempty
{-# INLINE _Cons #-}
instance Cons StrictB.ByteString StrictB.ByteString Word8 Word8 where
_Cons = prism' (uncurry StrictB.cons) StrictB.uncons
{-# INLINE _Cons #-}
instance Cons LazyB.ByteString LazyB.ByteString Word8 Word8 where
_Cons = prism' (uncurry LazyB.cons) LazyB.uncons
{-# INLINE _Cons #-}
instance Cons StrictT.Text StrictT.Text Char Char where
_Cons = prism' (uncurry StrictT.cons) StrictT.uncons
{-# INLINE _Cons #-}
instance Cons LazyT.Text LazyT.Text Char Char where
_Cons = prism' (uncurry LazyT.cons) LazyT.uncons
{-# INLINE _Cons #-}
instance Cons (Vector a) (Vector b) a b where
_Cons = prism (uncurry Vector.cons) $ \v ->
if Vector.null v
then Left Vector.empty
else Right (Vector.unsafeHead v, Vector.unsafeTail v)
{-# INLINE _Cons #-}
instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where
_Cons = prism (uncurry Prim.cons) $ \v ->
if Prim.null v
then Left Prim.empty
else Right (Prim.unsafeHead v, Prim.unsafeTail v)
{-# INLINE _Cons #-}
instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where
_Cons = prism (uncurry Storable.cons) $ \v ->
if Storable.null v
then Left Storable.empty
else Right (Storable.unsafeHead v, Storable.unsafeTail v)
{-# INLINE _Cons #-}
instance (Unbox a, Unbox b) => Cons (Unbox.Vector a) (Unbox.Vector b) a b where
_Cons = prism (uncurry Unbox.cons) $ \v ->
if Unbox.null v
then Left Unbox.empty
else Right (Unbox.unsafeHead v, Unbox.unsafeTail v)
{-# INLINE _Cons #-}
(<|) :: Cons s s a a => a -> s -> s
(<|) = curry (simply review _Cons)
{-# INLINE (<|) #-}
cons :: Cons s s a a => a -> s -> s
cons = curry (simply review _Cons)
{-# INLINE cons #-}
uncons :: Cons s s a a => s -> Maybe (a, s)
uncons = simply preview _Cons
{-# INLINE uncons #-}
_head :: Cons s s a a => Traversal' s a
_head = _Cons._1
{-# INLINE _head #-}
_tail :: Cons s s a a => Traversal' s s
_tail = _Cons._2
{-# INLINE _tail #-}
class Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where
_Snoc :: Prism s t (s,a) (t,b)
instance Snoc [a] [b] a b where
_Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas
then Left []
else Right (Prelude.init aas, Prelude.last aas)
{-# INLINE _Snoc #-}
instance a~b => Snoc (NonEmpty a) (NonEmpty b) a b where
_Snoc = prism' (\(x:|y,z) -> x:|y++[z]) $ \xyz -> case xyz of
x:|y
| Prelude.null y -> Nothing
| otherwise -> Just (x :| Prelude.init y, Prelude.last y)
instance Snoc (Seq a) (Seq b) a b where
_Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of
as Seq.:> a -> Right (as, a)
EmptyR -> Left mempty
{-# INLINE _Snoc #-}
instance Snoc (Vector a) (Vector b) a b where
_Snoc = prism (uncurry Vector.snoc) $ \v -> if Vector.null v
then Left Vector.empty
else Right (Vector.unsafeInit v, Vector.unsafeLast v)
{-# INLINE _Snoc #-}
instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where
_Snoc = prism (uncurry Prim.snoc) $ \v -> if Prim.null v
then Left Prim.empty
else Right (Prim.unsafeInit v, Prim.unsafeLast v)
{-# INLINE _Snoc #-}
instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where
_Snoc = prism (uncurry Storable.snoc) $ \v -> if Storable.null v
then Left Storable.empty
else Right (Storable.unsafeInit v, Storable.unsafeLast v)
{-# INLINE _Snoc #-}
instance (Unbox a, Unbox b) => Snoc (Unbox.Vector a) (Unbox.Vector b) a b where
_Snoc = prism (uncurry Unbox.snoc) $ \v -> if Unbox.null v
then Left Unbox.empty
else Right (Unbox.unsafeInit v, Unbox.unsafeLast v)
{-# INLINE _Snoc #-}
instance Snoc StrictB.ByteString StrictB.ByteString Word8 Word8 where
_Snoc = prism (uncurry StrictB.snoc) $ \v -> if StrictB.null v
then Left StrictB.empty
else Right (StrictB.init v, StrictB.last v)
{-# INLINE _Snoc #-}
instance Snoc LazyB.ByteString LazyB.ByteString Word8 Word8 where
_Snoc = prism (uncurry LazyB.snoc) $ \v -> if LazyB.null v
then Left LazyB.empty
else Right (LazyB.init v, LazyB.last v)
{-# INLINE _Snoc #-}
instance Snoc StrictT.Text StrictT.Text Char Char where
_Snoc = prism (uncurry StrictT.snoc) $ \v -> if StrictT.null v
then Left StrictT.empty
else Right (StrictT.init v, StrictT.last v)
{-# INLINE _Snoc #-}
instance Snoc LazyT.Text LazyT.Text Char Char where
_Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v
then Left LazyT.empty
else Right (LazyT.init v, LazyT.last v)
{-# INLINE _Snoc #-}
_init :: Snoc s s a a => Traversal' s s
_init = _Snoc._1
{-# INLINE _init #-}
_last :: Snoc s s a a => Traversal' s a
_last = _Snoc._2
{-# INLINE _last #-}
(|>) :: Snoc s s a a => s -> a -> s
(|>) = curry (simply review _Snoc)
{-# INLINE (|>) #-}
snoc :: Snoc s s a a => s -> a -> s
snoc = curry (simply review _Snoc)
{-# INLINE snoc #-}
unsnoc :: Snoc s s a a => s -> Maybe (s, a)
unsnoc s = simply preview _Snoc s
{-# INLINE unsnoc #-}