{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.Level
-- Copyright   :  (C) 2012-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module provides implementation details of the combinators in
-- "Control.Lens.Level", which provides for the breadth-first 'Control.Lens.Traversal.Traversal' of
-- an arbitrary 'Control.Lens.Traversal.Traversal'.
----------------------------------------------------------------------------
module Control.Lens.Internal.Level
  (
  -- * Levels
    Level(..)
  , Deepening(..), deepening
  , Flows(..)
  ) where

import Control.Applicative
import Control.Category
import Control.Comonad
import Data.Foldable
import Data.Functor.Apply
import Data.Int
import Data.Semigroup
import Data.Traversable
import Data.Word
import Prelude hiding ((.),id)

------------------------------------------------------------------------------
-- Levels
------------------------------------------------------------------------------

-- | This data type represents a path-compressed copy of one level of a source
-- data structure. We can safely use path-compression because we know the depth
-- of the tree.
--
-- Path compression is performed by viewing a 'Level' as a PATRICIA trie of the
-- paths into the structure to leaves at a given depth, similar in many ways
-- to a 'Data.IntMap.IntMap', but unlike a regular PATRICIA trie we do not need
-- to store the mask bits merely the depth of the fork.
--
-- One invariant of this structure is that underneath a 'Two' node you will not
-- find any 'Zero' nodes, so 'Zero' can only occur at the root.
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
(Level i a -> Level i a -> Bool)
-> (Level i a -> Level i a -> Bool) -> Eq (Level i a)
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,Eq (Level i a)
Eq (Level i a) =>
(Level i a -> Level i a -> Ordering)
-> (Level i a -> Level i a -> Bool)
-> (Level i a -> Level i a -> Bool)
-> (Level i a -> Level i a -> Bool)
-> (Level i a -> Level i a -> Bool)
-> (Level i a -> Level i a -> Level i a)
-> (Level i a -> Level i a -> Level i a)
-> Ord (Level i a)
Level i a -> Level i a -> Bool
Level i a -> Level i a -> Ordering
Level i a -> Level i a -> Level i a
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
$cp1Ord :: forall i a. (Ord i, Ord a) => Eq (Level i a)
Ord,Int -> Level i a -> ShowS
[Level i a] -> ShowS
Level i a -> String
(Int -> Level i a -> ShowS)
-> (Level i a -> String)
-> ([Level i a] -> ShowS)
-> Show (Level i a)
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)
Int -> ReadS (Level i a)
ReadS [Level i a]
(Int -> ReadS (Level i a))
-> ReadS [Level i a]
-> ReadPrec (Level i a)
-> ReadPrec [Level i a]
-> Read (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)

-- | Append a pair of 'Level' values to get a new 'Level' with path compression.
--
-- As the 'Level' type is user-visible, we do not expose this as an illegal
-- 'Semigroup' instance, and just use it directly in 'Deepening' as needed.
lappend :: Level i a -> Level i a -> Level i a
lappend :: Level i a -> Level i a -> Level i a
lappend Zero        Zero        = Level i a
forall i a. Level i a
Zero
lappend Zero        r :: Level i a
r@One{}     = Level i a
r
lappend l :: Level i a
l@One{}     Zero        = Level i a
l
lappend Zero        (Two n :: Word
n l :: Level i a
l r :: Level i a
r) = Word -> Level i a -> Level i a -> Level i a
forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1) Level i a
l Level i a
r
lappend (Two n :: Word
n l :: Level i a
l r :: Level i a
r) Zero        = Word -> Level i a -> Level i a -> Level i a
forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1) Level i a
l Level i a
r
lappend l :: Level i a
l           r :: Level i a
r           = Word -> Level i a -> Level i a -> Level i a
forall i a. Word -> Level i a -> Level i a -> Level i a
Two 0 Level i a
l Level i a
r
{-# INLINE lappend #-}

instance Functor (Level i) where
  fmap :: (a -> b) -> Level i a -> Level i b
fmap f :: a -> b
f = Level i a -> Level i b
go where
    go :: Level i a -> Level i b
go (Two n :: Word
n l :: Level i a
l r :: Level i a
r) = Word -> Level i b -> Level i b -> Level i b
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
i a :: a
a)   = i -> b -> Level i b
forall i a. i -> a -> Level i a
One i
i (a -> b
f a
a)
    go Zero        = Level i b
forall i a. Level i a
Zero
  {-# INLINE fmap #-}

instance Foldable (Level i) where
  foldMap :: (a -> m) -> Level i a -> m
foldMap f :: a -> m
f = Level i a -> m
go where
    go :: Level i a -> m
go (Two _ l :: Level i a
l r :: Level i a
r) = Level i a -> m
go Level i a
l m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` Level i a -> m
go Level i a
r
    go (One _ a :: a
a) = a -> m
f a
a
    go Zero = m
forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

instance Traversable (Level i) where
  traverse :: (a -> f b) -> Level i a -> f (Level i b)
traverse f :: a -> f b
f = Level i a -> f (Level i b)
go where
    go :: Level i a -> f (Level i b)
go (Two n :: Word
n l :: Level i a
l r :: Level i a
r) = Word -> Level i b -> Level i b -> Level i b
forall i a. Word -> Level i a -> Level i a -> Level i a
Two Word
n (Level i b -> Level i b -> Level i b)
-> f (Level i b) -> f (Level i b -> Level i b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level i a -> f (Level i b)
go Level i a
l f (Level i b -> Level i b) -> f (Level i b) -> f (Level i b)
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
i a :: a
a) = i -> b -> Level i b
forall i a. i -> a -> Level i a
One i
i (b -> Level i b) -> f b -> f (Level i b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
    go Zero = Level i b -> f (Level i b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level i b
forall i a. Level i a
Zero
  {-# INLINE traverse #-}

------------------------------------------------------------------------------
-- Generating Levels
------------------------------------------------------------------------------

-- | This is an illegal 'Monoid' used to construct a single 'Level'.
newtype Deepening i a = Deepening { 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 l :: forall r. Int -> (Level i a -> Bool -> r) -> r
l <> :: Deepening i a -> Deepening i a -> Deepening i a
<> Deepening r :: forall r. Int -> (Level i a -> Bool -> r) -> r
r = (forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening ((forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a)
-> (forall r. Int -> (Level i a -> Bool -> r) -> r)
-> Deepening i a
forall a b. (a -> b) -> a -> b
$ \ n :: Int
n k :: Level i a -> Bool -> r
k -> case Int
n of
    0 -> Level i a -> Bool -> r
k Level i a
forall i a. Level i a
Zero Bool
True
    _ -> let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 in Int -> (Level i a -> Bool -> r) -> r
forall r. Int -> (Level i a -> Bool -> r) -> r
l Int
n' ((Level i a -> Bool -> r) -> r) -> (Level i a -> Bool -> r) -> r
forall a b. (a -> b) -> a -> b
$ \x :: Level i a
x a :: Bool
a -> Int -> (Level i a -> Bool -> r) -> r
forall r. Int -> (Level i a -> Bool -> r) -> r
r Int
n' ((Level i a -> Bool -> r) -> r) -> (Level i a -> Bool -> r) -> r
forall a b. (a -> b) -> a -> b
$ \y :: Level i a
y b :: Bool
b -> Level i a -> Bool -> r
k (Level i a -> Level i a -> Level i a
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 (<>) #-}

-- | This is an illegal 'Monoid'.
instance Monoid (Deepening i a) where
  mempty :: Deepening i a
mempty = (forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening ((forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a)
-> (forall r. Int -> (Level i a -> Bool -> r) -> r)
-> Deepening i a
forall a b. (a -> b) -> a -> b
$ \ _ k :: Level i a -> Bool -> r
k -> Level i a -> Bool -> r
k Level i a
forall i a. Level i a
Zero Bool
False
  {-# INLINE mempty #-}
  mappend :: Deepening i a -> Deepening i a -> Deepening i a
mappend (Deepening l :: forall r. Int -> (Level i a -> Bool -> r) -> r
l) (Deepening r :: forall r. Int -> (Level i a -> Bool -> r) -> r
r) = (forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening ((forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a)
-> (forall r. Int -> (Level i a -> Bool -> r) -> r)
-> Deepening i a
forall a b. (a -> b) -> a -> b
$ \ n :: Int
n k :: Level i a -> Bool -> r
k -> case Int
n of
    0 -> Level i a -> Bool -> r
k Level i a
forall i a. Level i a
Zero Bool
True
    _ -> let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 in Int -> (Level i a -> Bool -> r) -> r
forall r. Int -> (Level i a -> Bool -> r) -> r
l Int
n' ((Level i a -> Bool -> r) -> r) -> (Level i a -> Bool -> r) -> r
forall a b. (a -> b) -> a -> b
$ \x :: Level i a
x a :: Bool
a -> Int -> (Level i a -> Bool -> r) -> r
forall r. Int -> (Level i a -> Bool -> r) -> r
r Int
n' ((Level i a -> Bool -> r) -> r) -> (Level i a -> Bool -> r) -> r
forall a b. (a -> b) -> a -> b
$ \y :: Level i a
y b :: Bool
b -> Level i a -> Bool -> r
k (Level i a -> Level i a -> Level i a
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 mappend #-}

-- | Generate the leaf of a given 'Deepening' based on whether or not we're at the correct depth.
deepening :: i -> a -> Deepening i a
deepening :: i -> a -> Deepening i a
deepening i :: i
i a :: a
a = (forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
forall i a.
(forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a
Deepening ((forall r. Int -> (Level i a -> Bool -> r) -> r) -> Deepening i a)
-> (forall r. Int -> (Level i a -> Bool -> r) -> r)
-> Deepening i a
forall a b. (a -> b) -> a -> b
$ \n :: Int
n k :: Level i a -> Bool -> r
k -> Level i a -> Bool -> r
k (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then i -> a -> Level i a
forall i a. i -> a -> Level i a
One i
i a
a else Level i a
forall i a. Level i a
Zero) Bool
False
{-# INLINE deepening #-}

------------------------------------------------------------------------------
-- Reassembling Levels
------------------------------------------------------------------------------

-- | This is an illegal 'Applicative' used to replace the contents of a list of consecutive 'Level' values
-- representing each layer of a structure into the original shape that they were derived from.
--
-- Attempting to 'Flow' something back into a shape other than the one it was taken from will fail.
newtype Flows i b a = Flows { Flows i b a -> [Level i b] -> a
runFlows :: [Level i b] -> a }

instance Functor (Flows i b) where
  fmap :: (a -> b) -> Flows i b a -> Flows i b b
fmap f :: a -> b
f (Flows g :: [Level i b] -> a
g) = ([Level i b] -> b) -> Flows i b b
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (a -> b
f (a -> b) -> ([Level i b] -> a) -> [Level i b] -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Level i b] -> a
g)
  {-# INLINE fmap #-}

-- | Walk down one constructor in a 'Level', veering left.
triml :: Level i b -> Level i b
triml :: Level i b -> Level i b
triml (Two 0 l :: Level i b
l _) = Level i b
l
triml (Two n :: Word
n l :: Level i b
l r :: Level i b
r) = Word -> Level i b -> Level i b -> Level i b
forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1) Level i b
l Level i b
r
triml x :: Level i b
x           = Level i b
x
{-# INLINE triml #-}

-- | Walk down one constructor in a 'Level', veering right.
trimr :: Level i b -> Level i b
trimr :: Level i b -> Level i b
trimr (Two 0 _ r :: Level i b
r) = Level i b
r
trimr (Two n :: Word
n l :: Level i b
l r :: Level i b
r) = Word -> Level i b -> Level i b -> Level i b
forall i a. Word -> Level i a -> Level i a -> Level i a
Two (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1) Level i b
l Level i b
r
trimr x :: Level i b
x           = Level i b
x
{-# INLINE trimr #-}

instance Apply (Flows i b) where
  Flows mf :: [Level i b] -> a -> b
mf <.> :: Flows i b (a -> b) -> Flows i b a -> Flows i b b
<.> Flows ma :: [Level i b] -> a
ma = ([Level i b] -> b) -> Flows i b b
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (([Level i b] -> b) -> Flows i b b)
-> ([Level i b] -> b) -> Flows i b b
forall a b. (a -> b) -> a -> b
$ \ xss :: [Level i b]
xss -> case [Level i b]
xss of
    []             -> [Level i b] -> a -> b
mf [] ([Level i b] -> a
ma [])
    (_:xs :: [Level i b]
xs)         -> [Level i b] -> a -> b
mf (Level i b -> Level i b
forall i b. Level i b -> Level i b
triml (Level i b -> Level i b) -> [Level i b] -> [Level i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs) (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ [Level i b] -> a
ma (Level i b -> Level i b
forall i b. Level i b -> Level i b
trimr (Level i b -> Level i b) -> [Level i b] -> [Level i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs)
  {-# INLINE (<.>) #-}

-- | This is an illegal 'Applicative'.
instance Applicative (Flows i b) where
  pure :: a -> Flows i b a
pure a :: a
a = ([Level i b] -> a) -> Flows i b a
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (a -> [Level i b] -> a
forall a b. a -> b -> a
const a
a)
  {-# INLINE pure #-}
  Flows mf :: [Level i b] -> a -> b
mf <*> :: Flows i b (a -> b) -> Flows i b a -> Flows i b b
<*> Flows ma :: [Level i b] -> a
ma = ([Level i b] -> b) -> Flows i b b
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (([Level i b] -> b) -> Flows i b b)
-> ([Level i b] -> b) -> Flows i b b
forall a b. (a -> b) -> a -> b
$ \ xss :: [Level i b]
xss -> case [Level i b]
xss of
    []             -> [Level i b] -> a -> b
mf [] ([Level i b] -> a
ma [])
    (_:xs :: [Level i b]
xs)         -> [Level i b] -> a -> b
mf (Level i b -> Level i b
forall i b. Level i b -> Level i b
triml (Level i b -> Level i b) -> [Level i b] -> [Level i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs) (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ [Level i b] -> a
ma (Level i b -> Level i b
forall i b. Level i b -> Level i b
trimr (Level i b -> Level i b) -> [Level i b] -> [Level i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Level i b]
xs)
  {-# INLINE (<*>) #-}