{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
module Control.Lens.Level
( Level
, levels
, ilevels
) where
import Control.Applicative
import Control.Lens.Internal.Bazaar
import Control.Lens.Internal.Context
import Control.Lens.Internal.Indexed
import Control.Lens.Internal.Level
import Control.Lens.Traversal
import Control.Lens.Type
import Data.Profunctor.Unsafe
levelIns :: BazaarT (->) f a b t -> [Level () a]
levelIns :: forall (f :: * -> *) a b t. BazaarT (->) f a b t -> [Level () a]
levelIns = forall {i} {a}. Int -> Deepening i a -> [Level i a]
go Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {k} a (b :: k). Const a b -> a
getConst forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar (forall (p :: * -> * -> *) a b x.
Profunctor p =>
p a b -> p a (Const b x)
rmapConst (forall i a. i -> a -> Deepening i a
deepening ()))) where
go :: Int -> Deepening i a -> [Level i a]
go Int
k Deepening i a
z = Int
k seq :: forall a b. a -> b -> b
`seq` forall i a.
Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
runDeepening Deepening i a
z Int
k forall a b. (a -> b) -> a -> b
$ \ Level i a
xs Bool
b ->
Level i a
xs forall a. a -> [a] -> [a]
: if Bool
b then (Int -> Deepening i a -> [Level i a]
go forall a b. (a -> b) -> a -> b
$! Int
k forall a. Num a => a -> a -> a
+ Int
1) Deepening i a
z else []
{-# INLINE levelIns #-}
levelOuts :: BazaarT (->) f a b t -> [Level j b] -> t
levelOuts :: forall (f :: * -> *) a b t j.
BazaarT (->) f a b t -> [Level j b] -> t
levelOuts BazaarT (->) f a b t
bz = forall i b a. Flows i b a -> [Level i b] -> a
runFlows forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (g :: * -> *) a b t.
BazaarT p g a b t
-> forall (f :: * -> *). Applicative f => p a (f b) -> f t
runBazaarT BazaarT (->) f a b t
bz forall a b. (a -> b) -> a -> b
$ \ a
_ -> forall i b a. ([Level i b] -> a) -> Flows i b a
Flows forall a b. (a -> b) -> a -> b
$ \[Level j b]
t -> case [Level j b]
t of
One j
_ b
a : [Level j b]
_ -> b
a
[Level j b]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"levelOuts: wrong shape"
{-# INLINE levelOuts #-}
levels :: Applicative f
=> Traversing (->) f s t a b
-> IndexedLensLike Int f s t (Level () a) (Level () b)
levels :: forall (f :: * -> *) s t a b.
Applicative f =>
Traversing (->) f s t a b
-> IndexedLensLike Int f s t (Level () a) (Level () b)
levels Traversing (->) f s t a b
l p (Level () a) (f (Level () b))
f s
s = forall (f :: * -> *) a b t j.
BazaarT (->) f a b t -> [Level j b] -> t
levelOuts BazaarT (->) f a b t
bz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed p (Level () a) (f (Level () b))
f (forall (f :: * -> *) a b t. BazaarT (->) f a b t -> [Level () a]
levelIns BazaarT (->) f a b t
bz) where
bz :: BazaarT (->) f a b t
bz = Traversing (->) f s t a b
l forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s
{-# INLINE levels #-}
rmapConst :: Profunctor p => p a b -> p a (Const b x)
rmapConst :: forall (p :: * -> * -> *) a b x.
Profunctor p =>
p a b -> p a (Const b x)
rmapConst p a b
p = forall {k} a (b :: k). a -> Const a b
Const forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. p a b
p
{-# INLINE rmapConst #-}
ilevelIns :: BazaarT (Indexed i) f a b t -> [Level i a]
ilevelIns :: forall i (f :: * -> *) a b t.
BazaarT (Indexed i) f a b t -> [Level i a]
ilevelIns = forall {i} {a}. Int -> Deepening i a -> [Level i a]
go Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {k} a (b :: k). Const a b -> a
getConst forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar (forall i a b. (i -> a -> b) -> Indexed i a b
Indexed forall a b. (a -> b) -> a -> b
$ \ i
i -> forall (p :: * -> * -> *) a b x.
Profunctor p =>
p a b -> p a (Const b x)
rmapConst (forall i a. i -> a -> Deepening i a
deepening i
i))) where
go :: Int -> Deepening i a -> [Level i a]
go Int
k Deepening i a
z = Int
k seq :: forall a b. a -> b -> b
`seq` forall i a.
Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
runDeepening Deepening i a
z Int
k forall a b. (a -> b) -> a -> b
$ \ Level i a
xs Bool
b ->
Level i a
xs forall a. a -> [a] -> [a]
: if Bool
b then (Int -> Deepening i a -> [Level i a]
go forall a b. (a -> b) -> a -> b
$! Int
k forall a. Num a => a -> a -> a
+ Int
1) Deepening i a
z else []
{-# INLINE ilevelIns #-}
ilevelOuts :: BazaarT (Indexed i) f a b t -> [Level j b] -> t
ilevelOuts :: forall i (f :: * -> *) a b t j.
BazaarT (Indexed i) f a b t -> [Level j b] -> t
ilevelOuts BazaarT (Indexed i) f a b t
bz = forall i b a. Flows i b a -> [Level i b] -> a
runFlows forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (g :: * -> *) a b t.
BazaarT p g a b t
-> forall (f :: * -> *). Applicative f => p a (f b) -> f t
runBazaarT BazaarT (Indexed i) f a b t
bz forall a b. (a -> b) -> a -> b
$ forall i a b. (i -> a -> b) -> Indexed i a b
Indexed forall a b. (a -> b) -> a -> b
$ \ i
_ a
_ -> forall i b a. ([Level i b] -> a) -> Flows i b a
Flows forall a b. (a -> b) -> a -> b
$ \[Level j b]
t -> case [Level j b]
t of
One j
_ b
a : [Level j b]
_ -> b
a
[Level j b]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"ilevelOuts: wrong shape"
{-# INLINE ilevelOuts #-}
ilevels :: Applicative f
=> Traversing (Indexed i) f s t a b
-> IndexedLensLike Int f s t (Level i a) (Level j b)
ilevels :: forall (f :: * -> *) i s t a b j.
Applicative f =>
Traversing (Indexed i) f s t a b
-> IndexedLensLike Int f s t (Level i a) (Level j b)
ilevels Traversing (Indexed i) f s t a b
l p (Level i a) (f (Level j b))
f s
s = forall i (f :: * -> *) a b t j.
BazaarT (Indexed i) f a b t -> [Level j b] -> t
ilevelOuts BazaarT (Indexed i) f a b t
bz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed p (Level i a) (f (Level j b))
f (forall i (f :: * -> *) a b t.
BazaarT (Indexed i) f a b t -> [Level i a]
ilevelIns BazaarT (Indexed i) f a b t
bz) where
bz :: BazaarT (Indexed i) f a b t
bz = Traversing (Indexed i) f s t a b
l forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s
{-# INLINE ilevels #-}