{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Lens.Internal.Level
(
Level(..)
, Deepening(..), deepening
, Flows(..)
) where
import Prelude ()
import Control.Lens.Internal.Prelude
import Data.Functor.Apply
import Data.Functor.WithIndex
import Data.Foldable.WithIndex
import Data.Traversable.WithIndex
data Level i a
= Two {-# UNPACK #-} !Word !(Level i a) !(Level i a)
| One i a
| Zero
deriving (Level i a -> Level i a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall i a. (Eq i, Eq a) => Level i a -> Level i a -> Bool
/= :: Level i a -> Level i a -> Bool
$c/= :: forall i a. (Eq i, Eq a) => Level i a -> Level i a -> Bool
== :: Level i a -> Level i a -> Bool
$c== :: forall i a. (Eq i, Eq a) => Level i a -> Level i a -> Bool
Eq,Level i a -> Level i a -> Bool
Level i a -> Level i a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {i} {a}. (Ord i, Ord a) => Eq (Level i a)
forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Bool
forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Ordering
forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Level i a
min :: Level i a -> Level i a -> Level i a
$cmin :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Level i a
max :: Level i a -> Level i a -> Level i a
$cmax :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Level i a
>= :: Level i a -> Level i a -> Bool
$c>= :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Bool
> :: Level i a -> Level i a -> Bool
$c> :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Bool
<= :: Level i a -> Level i a -> Bool
$c<= :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Bool
< :: Level i a -> Level i a -> Bool
$c< :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Bool
compare :: Level i a -> Level i a -> Ordering
$ccompare :: forall i a. (Ord i, Ord a) => Level i a -> Level i a -> Ordering
Ord,Int -> Level i a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall i a. (Show i, Show a) => Int -> Level i a -> ShowS
forall i a. (Show i, Show a) => [Level i a] -> ShowS
forall i a. (Show i, Show a) => Level i a -> String
showList :: [Level i a] -> ShowS
$cshowList :: forall i a. (Show i, Show a) => [Level i a] -> ShowS
show :: Level i a -> String
$cshow :: forall i a. (Show i, Show a) => Level i a -> String
showsPrec :: Int -> Level i a -> ShowS
$cshowsPrec :: forall i a. (Show i, Show a) => Int -> Level i a -> ShowS
Show,ReadPrec [Level i a]
ReadPrec (Level i a)
ReadS [Level i a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall i a. (Read i, Read a) => ReadPrec [Level i a]
forall i a. (Read i, Read a) => ReadPrec (Level i a)
forall i a. (Read i, Read a) => Int -> ReadS (Level i a)
forall i a. (Read i, Read a) => ReadS [Level i a]
readListPrec :: ReadPrec [Level i a]
$creadListPrec :: forall i a. (Read i, Read a) => ReadPrec [Level i a]
readPrec :: ReadPrec (Level i a)
$creadPrec :: forall i a. (Read i, Read a) => ReadPrec (Level i a)
readList :: ReadS [Level i a]
$creadList :: forall i a. (Read i, Read a) => ReadS [Level i a]
readsPrec :: Int -> ReadS (Level i a)
$creadsPrec :: forall i a. (Read i, Read a) => Int -> ReadS (Level i a)
Read)
lappend :: Level i a -> Level i a -> Level i a
lappend :: forall i a. Level i a -> Level i a -> Level i a
lappend Level i a
Zero Level i a
Zero = forall i a. Level i a
Zero
lappend Level i a
Zero r :: Level i a
r@One{} = Level i a
r
lappend l :: Level i a
l@One{} Level i a
Zero = Level i a
l
lappend Level i a
Zero (Two Word
n Level i a
l Level i a
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n forall a. Num a => a -> a -> a
+ Word
1) Level i a
l Level i a
r
lappend (Two Word
n Level i a
l Level i a
r) Level i a
Zero = forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n forall a. Num a => a -> a -> a
+ Word
1) Level i a
l Level i a
r
lappend Level i a
l Level i a
r = forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
0 Level i a
l Level i a
r
{-# INLINE lappend #-}
instance Functor (Level i) where
fmap :: forall a b. (a -> b) -> Level i a -> Level i b
fmap a -> b
f = Level i a -> Level i b
go where
go :: Level i a -> Level i b
go (Two Word
n Level i a
l Level i a
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
n (Level i a -> Level i b
go Level i a
l) (Level i a -> Level i b
go Level i a
r)
go (One i
i a
a) = forall i a. i -> a -> Level i a
One i
i (a -> b
f a
a)
go Level i a
Zero = forall i a. Level i a
Zero
{-# INLINE fmap #-}
instance Foldable (Level i) where
foldMap :: forall m a. Monoid m => (a -> m) -> Level i a -> m
foldMap a -> m
f = Level i a -> m
go where
go :: Level i a -> m
go (Two Word
_ Level i a
l Level i a
r) = Level i a -> m
go Level i a
l forall a. Monoid a => a -> a -> a
`mappend` Level i a -> m
go Level i a
r
go (One i
_ a
a) = a -> m
f a
a
go Level i a
Zero = forall a. Monoid a => a
mempty
{-# INLINE foldMap #-}
instance Traversable (Level i) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Level i a -> f (Level i b)
traverse a -> f b
f = Level i a -> f (Level i b)
go where
go :: Level i a -> f (Level i b)
go (Two Word
n Level i a
l Level i a
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level i a -> f (Level i b)
go Level i a
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Level i a -> f (Level i b)
go Level i a
r
go (One i
i a
a) = forall i a. i -> a -> Level i a
One i
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
go Level i a
Zero = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall i a. Level i a
Zero
{-# INLINE traverse #-}
instance FunctorWithIndex i (Level i) where
imap :: forall a b. (i -> a -> b) -> Level i a -> Level i b
imap i -> a -> b
f = Level i a -> Level i b
go where
go :: Level i a -> Level i b
go (Two Word
n Level i a
l Level i a
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
n (Level i a -> Level i b
go Level i a
l) (Level i a -> Level i b
go Level i a
r)
go (One i
i a
a) = forall i a. i -> a -> Level i a
One i
i (i -> a -> b
f i
i a
a)
go Level i a
Zero = forall i a. Level i a
Zero
{-# INLINE imap #-}
instance FoldableWithIndex i (Level i) where
ifoldMap :: forall m a. Monoid m => (i -> a -> m) -> Level i a -> m
ifoldMap i -> a -> m
f = Level i a -> m
go where
go :: Level i a -> m
go (Two Word
_ Level i a
l Level i a
r) = Level i a -> m
go Level i a
l forall a. Monoid a => a -> a -> a
`mappend` Level i a -> m
go Level i a
r
go (One i
i a
a) = i -> a -> m
f i
i a
a
go Level i a
Zero = forall a. Monoid a => a
mempty
{-# INLINE ifoldMap #-}
instance TraversableWithIndex i (Level i) where
itraverse :: forall (f :: * -> *) a b.
Applicative f =>
(i -> a -> f b) -> Level i a -> f (Level i b)
itraverse i -> a -> f b
f = Level i a -> f (Level i b)
go where
go :: Level i a -> f (Level i b)
go (Two Word
n Level i a
l Level i a
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level i a -> f (Level i b)
go Level i a
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Level i a -> f (Level i b)
go Level i a
r
go (One i
i a
a) = forall i a. i -> a -> Level i a
One i
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> a -> f b
f i
i a
a
go Level i a
Zero = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall i a. Level i a
Zero
{-# INLINE itraverse #-}
newtype Deepening i a = Deepening { forall i a.
Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
runDeepening :: forall r. Int -> (Level i a -> Bool -> r) -> r }
instance Semigroup (Deepening i a) where
Deepening forall r. Int -> (Level i a -> Bool -> r) -> r
l <> :: Deepening i a -> Deepening i a -> Deepening i a
<> Deepening forall r. Int -> (Level i a -> Bool -> r) -> r
r = forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening forall a b. (a -> b) -> a -> b
$ \ Int
n Level i a -> Bool -> r
k -> case Int
n of
Int
0 -> Level i a -> Bool -> r
k forall i a. Level i a
Zero Bool
True
Int
_ -> let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
- Int
1 in forall r. Int -> (Level i a -> Bool -> r) -> r
l Int
n' forall a b. (a -> b) -> a -> b
$ \Level i a
x Bool
a -> forall r. Int -> (Level i a -> Bool -> r) -> r
r Int
n' forall a b. (a -> b) -> a -> b
$ \Level i a
y Bool
b -> Level i a -> Bool -> r
k (forall i a. Level i a -> Level i a -> Level i a
lappend Level i a
x Level i a
y) (Bool
a Bool -> Bool -> Bool
|| Bool
b)
{-# INLINE (<>) #-}
instance Monoid (Deepening i a) where
mempty :: Deepening i a
mempty = forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening forall a b. (a -> b) -> a -> b
$ \ Int
_ Level i a -> Bool -> r
k -> Level i a -> Bool -> r
k forall i a. Level i a
Zero Bool
False
{-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
mappend (Deepening l) (Deepening r) = Deepening $ \ n k -> case n of
0 -> k Zero True
_ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b)
{-# INLINE mappend #-}
#endif
deepening :: i -> a -> Deepening i a
deepening :: forall i a. i -> a -> Deepening i a
deepening i
i a
a = forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening forall a b. (a -> b) -> a -> b
$ \Int
n Level i a -> Bool -> r
k -> Level i a -> Bool -> r
k (if Int
n forall a. Eq a => a -> a -> Bool
== Int
0 then forall i a. i -> a -> Level i a
One i
i a
a else forall i a. Level i a
Zero) Bool
False
{-# INLINE deepening #-}
newtype Flows i b a = Flows { forall i b a. Flows i b a -> [Level i b] -> a
runFlows :: [Level i b] -> a }
instance Functor (Flows i b) where
fmap :: forall a b. (a -> b) -> Flows i b a -> Flows i b b
fmap a -> b
f (Flows [Level i b] -> a
g) = forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Level i b] -> a
g)
{-# INLINE fmap #-}
triml :: Level i b -> Level i b
triml :: forall i b. Level i b -> Level i b
triml (Two Word
0 Level i b
l Level i b
_) = Level i b
l
triml (Two Word
n Level i b
l Level i b
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n forall a. Num a => a -> a -> a
- Word
1) Level i b
l Level i b
r
triml Level i b
x = Level i b
x
{-# INLINE triml #-}
trimr :: Level i b -> Level i b
trimr :: forall i b. Level i b -> Level i b
trimr (Two Word
0 Level i b
_ Level i b
r) = Level i b
r
trimr (Two Word
n Level i b
l Level i b
r) = forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n forall a. Num a => a -> a -> a
- Word
1) Level i b
l Level i b
r
trimr Level i b
x = Level i b
x
{-# INLINE trimr #-}
instance Apply (Flows i b) where
Flows [Level i b] -> a -> b
mf <.> :: forall a b. Flows i b (a -> b) -> Flows i b a -> Flows i b b
<.> Flows [Level i b] -> a
ma = forall i b a. ([Level i b] -> a) -> Flows i b a
Flows forall a b. (a -> b) -> a -> b
$ \ [Level i b]
xss -> case [Level i b]
xss of
[] -> [Level i b] -> a -> b
mf [] ([Level i b] -> a
ma [])
(Level i b
_:[Level i b]
xs) -> [Level i b] -> a -> b
mf (forall i b. Level i b -> Level i b
triml forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs) forall a b. (a -> b) -> a -> b
$ [Level i b] -> a
ma (forall i b. Level i b -> Level i b
trimr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs)
{-# INLINE (<.>) #-}
instance Applicative (Flows i b) where
pure :: forall a. a -> Flows i b a
pure a
a = forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (forall a b. a -> b -> a
const a
a)
{-# INLINE pure #-}
Flows [Level i b] -> a -> b
mf <*> :: forall a b. Flows i b (a -> b) -> Flows i b a -> Flows i b b
<*> Flows [Level i b] -> a
ma = forall i b a. ([Level i b] -> a) -> Flows i b a
Flows forall a b. (a -> b) -> a -> b
$ \ [Level i b]
xss -> case [Level i b]
xss of
[] -> [Level i b] -> a -> b
mf [] ([Level i b] -> a
ma [])
(Level i b
_:[Level i b]
xs) -> [Level i b] -> a -> b
mf (forall i b. Level i b -> Level i b
triml forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs) forall a b. (a -> b) -> a -> b
$ [Level i b] -> a
ma (forall i b. Level i b -> Level i b
trimr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs)
{-# INLINE (<*>) #-}