{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Strict.Sequence.Lens
  ( viewL
  , viewR
  , slicedTo
  , slicedFrom
  , sliced
  , seqOf
  ) where

import           Control.Lens

import qualified Data.Foldable as Foldable
import qualified Data.Strict.Sequence as Seq

import           Data.Strict.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), (><), viewl, viewr)


#if !MIN_VERSION_lens(5,0,0)
instance FunctorWithIndex Int Seq where
  imap = Seq.mapWithIndex
  {-# INLINE imap #-}

instance FoldableWithIndex Int Seq where
  ifoldMap = Seq.foldMapWithIndex
  {-# INLINE ifoldMap #-}
  ifoldr = Seq.foldrWithIndex
  {-# INLINE ifoldr #-}
  ifoldl f = Seq.foldlWithIndex (flip f)
  {-# INLINE ifoldl #-}

instance TraversableWithIndex Int Seq where
  itraverse = Seq.traverseWithIndex
  {-# INLINE itraverse #-}
#endif

type instance Index (Seq a) = Int
type instance IxValue (Seq a) = a
instance Ixed (Seq a) where
  -- This is slightly different from lens' definition to make our ixTest work.
  -- It is analogous to how Map.ix is defined.
  ix :: Index (Seq a) -> Traversal' (Seq a) (IxValue (Seq a))
ix Index (Seq a)
i IxValue (Seq a) -> f (IxValue (Seq a))
f Seq a
m = case Int -> Seq a -> Maybe a
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
Index (Seq a)
i Seq a
m of
    Maybe a
Nothing -> Seq a -> f (Seq a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq a
m
    Just a
v -> IxValue (Seq a) -> f (IxValue (Seq a))
f a
IxValue (Seq a)
v f a -> (a -> Seq a) -> f (Seq a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \a
a -> Int -> a -> Seq a -> Seq a
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
Index (Seq a)
i a
a Seq a
m
  {-# INLINE ix #-}

instance AsEmpty (Seq a) where
  _Empty :: p () (f ()) -> p (Seq a) (f (Seq a))
_Empty = Seq a -> (Seq a -> Bool) -> Prism' (Seq a) ()
forall a. a -> (a -> Bool) -> Prism' a ()
nearly Seq a
forall a. Seq a
Seq.empty Seq a -> Bool
forall a. Seq a -> Bool
Seq.null
  {-# INLINE _Empty #-}

instance Each (Seq a) (Seq b) a b where
  each :: (a -> f b) -> Seq a -> f (Seq b)
each = (a -> f b) -> Seq a -> f (Seq b)
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed
  {-# INLINE each #-}

instance (t ~ Seq a') => Rewrapped (Seq a) t
instance Wrapped (Seq a) where
  type Unwrapped (Seq a) = [a]
  _Wrapped' :: p (Unwrapped (Seq a)) (f (Unwrapped (Seq a)))
-> p (Seq a) (f (Seq a))
_Wrapped' = (Seq a -> [a]) -> ([a] -> Seq a) -> Iso (Seq a) (Seq a) [a] [a]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList
  {-# INLINE _Wrapped' #-}

instance Cons (Seq a) (Seq b) a b where
  _Cons :: p (a, Seq a) (f (b, Seq b)) -> p (Seq a) (f (Seq b))
_Cons = ((b, Seq b) -> Seq b)
-> (Seq a -> Either (Seq b) (a, Seq a))
-> Prism (Seq a) (Seq b) (a, Seq a) (b, Seq b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b -> Seq b -> Seq b) -> (b, Seq b) -> Seq b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> Seq b -> Seq b
forall a. a -> Seq a -> Seq a
(Seq.<|)) ((Seq a -> Either (Seq b) (a, Seq a))
 -> Prism (Seq a) (Seq b) (a, Seq a) (b, Seq b))
-> (Seq a -> Either (Seq b) (a, Seq a))
-> Prism (Seq a) (Seq b) (a, Seq a) (b, Seq b)
forall a b. (a -> b) -> a -> b
$ \Seq a
aas -> case Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl Seq a
aas of
    a
a Seq.:< Seq a
as -> (a, Seq a) -> Either (Seq b) (a, Seq a)
forall a b. b -> Either a b
Right (a
a, Seq a
as)
    ViewL a
EmptyL  -> Seq b -> Either (Seq b) (a, Seq a)
forall a b. a -> Either a b
Left Seq b
forall a. Monoid a => a
mempty
  {-# INLINE _Cons #-}

instance Snoc (Seq a) (Seq b) a b where
  _Snoc :: p (Seq a, a) (f (Seq b, b)) -> p (Seq a) (f (Seq b))
_Snoc = ((Seq b, b) -> Seq b)
-> (Seq a -> Either (Seq b) (Seq a, a))
-> Prism (Seq a) (Seq b) (Seq a, a) (Seq b, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((Seq b -> b -> Seq b) -> (Seq b, b) -> Seq b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Seq b -> b -> Seq b
forall a. Seq a -> a -> Seq a
(Seq.|>)) ((Seq a -> Either (Seq b) (Seq a, a))
 -> Prism (Seq a) (Seq b) (Seq a, a) (Seq b, b))
-> (Seq a -> Either (Seq b) (Seq a, a))
-> Prism (Seq a) (Seq b) (Seq a, a) (Seq b, b)
forall a b. (a -> b) -> a -> b
$ \Seq a
aas -> case Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr Seq a
aas of
    Seq a
as Seq.:> a
a -> (Seq a, a) -> Either (Seq b) (Seq a, a)
forall a b. b -> Either a b
Right (Seq a
as, a
a)
    ViewR a
EmptyR  -> Seq b -> Either (Seq b) (Seq a, a)
forall a b. a -> Either a b
Left Seq b
forall a. Monoid a => a
mempty
  {-# INLINE _Snoc #-}

instance Reversing (Seq a) where
  reversing :: Seq a -> Seq a
reversing = Seq a -> Seq a
forall a. Seq a -> Seq a
Seq.reverse

-- | Analogous to 'Data.Sequence.Lens.viewL'.
viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)
viewL :: p (ViewL a) (f (ViewL b)) -> p (Seq a) (f (Seq b))
viewL = (Seq a -> ViewL a)
-> (ViewL b -> Seq b) -> Iso (Seq a) (Seq b) (ViewL a) (ViewL b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl ((ViewL b -> Seq b) -> Iso (Seq a) (Seq b) (ViewL a) (ViewL b))
-> (ViewL b -> Seq b) -> Iso (Seq a) (Seq b) (ViewL a) (ViewL b)
forall a b. (a -> b) -> a -> b
$ \ ViewL b
xs -> case ViewL b
xs of
  ViewL b
EmptyL ->  Seq b
forall a. Monoid a => a
mempty
  b
a Seq.:< Seq b
as -> b
a b -> Seq b -> Seq b
forall a. a -> Seq a -> Seq a
Seq.<| Seq b
as
{-# INLINE viewL #-}

-- | Analogous to 'Data.Sequence.Lens.viewR'.
viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)
viewR :: p (ViewR a) (f (ViewR b)) -> p (Seq a) (f (Seq b))
viewR = (Seq a -> ViewR a)
-> (ViewR b -> Seq b) -> Iso (Seq a) (Seq b) (ViewR a) (ViewR b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr ((ViewR b -> Seq b) -> Iso (Seq a) (Seq b) (ViewR a) (ViewR b))
-> (ViewR b -> Seq b) -> Iso (Seq a) (Seq b) (ViewR a) (ViewR b)
forall a b. (a -> b) -> a -> b
$ \ViewR b
xs -> case ViewR b
xs of
  ViewR b
EmptyR  -> Seq b
forall a. Monoid a => a
mempty
  Seq b
as Seq.:> b
a -> Seq b
as Seq b -> b -> Seq b
forall a. Seq a -> a -> Seq a
Seq.|> b
a
{-# INLINE viewR #-}

-- | Analogous to 'Data.Sequence.Lens.slicedTo'.
slicedTo :: Int -> IndexedTraversal' Int (Seq a) a
slicedTo :: Int -> IndexedTraversal' Int (Seq a) a
slicedTo Int
n p a (f a)
f Seq a
m = case Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n Seq a
m of
  (Seq a
l,Seq a
r) -> (Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
r) (Seq a -> Seq a) -> f (Seq a) -> f (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> a -> f a) -> Seq a -> f (Seq a)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (p a (f a) -> Int -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f) Seq a
l
{-# INLINE slicedTo #-}

-- | Analogous to 'Data.Sequence.Lens.slicedFrom'.
slicedFrom :: Int -> IndexedTraversal' Int (Seq a) a
slicedFrom :: Int -> IndexedTraversal' Int (Seq a) a
slicedFrom Int
n p a (f a)
f Seq a
m = case Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n Seq a
m of
  (Seq a
l,Seq a
r) -> (Seq a
l Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
><) (Seq a -> Seq a) -> f (Seq a) -> f (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> a -> f a) -> Seq a -> f (Seq a)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (p a (f a) -> Int -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f (Int -> a -> f a) -> (Int -> Int) -> Int -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)) Seq a
r
{-# INLINE slicedFrom #-}

-- | Analogous to 'Data.Sequence.Lens.sliced'.
sliced :: Int -> Int -> IndexedTraversal' Int (Seq a) a
sliced :: Int -> Int -> IndexedTraversal' Int (Seq a) a
sliced Int
i Int
j p a (f a)
f Seq a
s = case Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
i Seq a
s of
  (Seq a
l,Seq a
mr) -> case Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) Seq a
mr of
     (Seq a
m, Seq a
r) -> (Int -> a -> f a) -> Seq a -> f (Seq a)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (p a (f a) -> Int -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
f (Int -> a -> f a) -> (Int -> Int) -> Int -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)) Seq a
m f (Seq a) -> (Seq a -> Seq a) -> f (Seq a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Seq a
n -> Seq a
l Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
n Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
>< Seq a
r
{-# INLINE sliced #-}

-- | Analogous to 'Data.Sequence.Lens.seqOf'.
seqOf :: Getting (Seq a) s a -> s -> Seq a
seqOf :: Getting (Seq a) s a -> s -> Seq a
seqOf Getting (Seq a) s a
l = Getting (Seq a) s a -> (a -> Seq a) -> s -> Seq a
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Getting (Seq a) s a
l a -> Seq a
forall a. a -> Seq a
Seq.singleton
{-# INLINE seqOf #-}