{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Level
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
-- This module provides combinators for breadth-first searching within
-- arbitrary traversals.
----------------------------------------------------------------------------
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

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.Char

levelIns :: BazaarT (->) f a b t -> [Level () a]
levelIns :: forall (f :: * -> *) a b t. BazaarT (->) f a b t -> [Level () a]
levelIns = Int -> Deepening () a -> [Level () a]
forall {i} {a}. Int -> Deepening i a -> [Level i a]
go Int
0 (Deepening () a -> [Level () a])
-> (BazaarT (->) f a b t -> Deepening () a)
-> BazaarT (->) f a b t
-> [Level () a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Const (Deepening () a) t -> Deepening () a
forall {k} a (b :: k). Const a b -> a
getConst (Const (Deepening () a) t -> Deepening () a)
-> (BazaarT (->) f a b t -> Const (Deepening () a) t)
-> BazaarT (->) f a b t
-> Deepening () a
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> Const (Deepening () a) b)
-> BazaarT (->) f a b t -> Const (Deepening () a) t
forall (f :: * -> *) a b t.
Applicative f =>
(a -> f b) -> BazaarT (->) f a b t -> f t
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
       t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar ((a -> Deepening () a) -> a -> Const (Deepening () a) b
forall (p :: * -> * -> *) a b x.
Profunctor p =>
p a b -> p a (Const b x)
rmapConst (() -> a -> Deepening () a
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 Int -> [Level i a] -> [Level i a]
forall a b. a -> b -> b
`seq` Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
forall i a.
Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
runDeepening Deepening i a
z Int
k ((Level i a -> Bool -> [Level i a]) -> [Level i a])
-> (Level i a -> Bool -> [Level i a]) -> [Level i a]
forall a b. (a -> b) -> a -> b
$ \ Level i a
xs Bool
b ->
    Level i a
xs Level i a -> [Level i a] -> [Level i a]
forall a. a -> [a] -> [a]
: if Bool
b then (Int -> Deepening i a -> [Level i a]
go (Int -> Deepening i a -> [Level i a])
-> Int -> Deepening i a -> [Level i a]
forall a b. (a -> b) -> a -> b
$! Int
k Int -> Int -> Int
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 = Flows j b t -> [Level j b] -> t
forall i b a. Flows i b a -> [Level i b] -> a
runFlows (Flows j b t -> [Level j b] -> t)
-> Flows j b t -> [Level j b] -> t
forall a b. (a -> b) -> a -> b
$ BazaarT (->) f a b t
-> forall (f :: * -> *). Applicative f => (a -> f b) -> f t
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 ((a -> Flows j b b) -> Flows j b t)
-> (a -> Flows j b b) -> Flows j b t
forall a b. (a -> b) -> a -> b
$ \ a
_ -> ([Level j b] -> b) -> Flows j b b
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (([Level j b] -> b) -> Flows j b b)
-> ([Level j b] -> b) -> Flows j b b
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]
_           -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"levelOuts: wrong shape"
{-# INLINE levelOuts #-}

-- | This provides a breadth-first 'Traversal' or 'Fold' of the individual
-- 'levels' of any other 'Traversal' or 'Fold' via iterative deepening
-- depth-first search. The levels are returned to you in a compressed format.
--
-- This can permit us to extract the 'levels' directly:
--
-- >>> ["hello","world"]^..levels (traverse.traverse)
-- [Zero,Zero,One () 'h',Two 0 (One () 'e') (One () 'w'),Two 0 (One () 'l') (One () 'o'),Two 0 (One () 'l') (One () 'r'),Two 0 (One () 'o') (One () 'l'),One () 'd']
--
-- But we can also traverse them in turn:
--
-- >>> ["hello","world"]^..levels (traverse.traverse).traverse
-- "hewlolrold"
--
-- We can use this to traverse to a fixed depth in the tree of ('<*>') used in the 'Traversal':
--
-- >>> ["hello","world"] & taking 4 (levels (traverse.traverse)).traverse %~ toUpper
-- ["HEllo","World"]
--
-- Or we can use it to traverse the first @n@ elements in found in that 'Traversal' regardless of the depth
-- at which they were found.
--
-- >>> ["hello","world"] & taking 4 (levels (traverse.traverse).traverse) %~ toUpper
-- ["HELlo","World"]
--
-- The resulting 'Traversal' of the 'levels' which is indexed by the depth of each 'Level'.
--
-- >>> ["dog","cat"]^@..levels (traverse.traverse) <. traverse
-- [(2,'d'),(3,'o'),(3,'c'),(4,'g'),(4,'a'),(5,'t')]
--
-- @
-- 'levels' :: 'Traversal' s t a b      -> 'IndexedTraversal' 'Int' s t ('Level' () a) ('Level' () b)
-- 'levels' :: 'Fold' s a               -> 'IndexedFold' 'Int' s ('Level' () a)
-- @
--
-- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information
-- in an order that violates the 'Applicative' laws.
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 = BazaarT (->) f a b t -> [Level () b] -> t
forall (f :: * -> *) a b t j.
BazaarT (->) f a b t -> [Level j b] -> t
levelOuts BazaarT (->) f a b t
bz ([Level () b] -> t) -> f [Level () b] -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p (Level () a) (f (Level () b)) -> [Level () a] -> f [Level () b]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal
  Int [Level () a] [Level () b] (Level () a) (Level () b)
traversed p (Level () a) (f (Level () b))
f (BazaarT (->) f a b t -> [Level () a]
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 a -> BazaarT (->) f a b b
forall a b. a -> BazaarT (->) f a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s
{-# INLINE levels #-}

-- This is only a temporary work around added to deal with a bug in an unreleased version
-- of GHC 7.10. We should remove it as soon as we're able.
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 = b -> Const b x
forall {k} a (b :: k). a -> Const a b
Const (b -> Const b x) -> p a b -> p a (Const b x)
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> p a b -> p a c
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 = Int -> Deepening i a -> [Level i a]
forall {i} {a}. Int -> Deepening i a -> [Level i a]
go Int
0 (Deepening i a -> [Level i a])
-> (BazaarT (Indexed i) f a b t -> Deepening i a)
-> BazaarT (Indexed i) f a b t
-> [Level i a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Const (Deepening i a) t -> Deepening i a
forall {k} a (b :: k). Const a b -> a
getConst (Const (Deepening i a) t -> Deepening i a)
-> (BazaarT (Indexed i) f a b t -> Const (Deepening i a) t)
-> BazaarT (Indexed i) f a b t
-> Deepening i a
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Indexed i a (Const (Deepening i a) b)
-> BazaarT (Indexed i) f a b t -> Const (Deepening i a) t
forall (f :: * -> *) a b t.
Applicative f =>
Indexed i a (f b) -> BazaarT (Indexed i) f a b t -> f t
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
       t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar ((i -> a -> Const (Deepening i a) b)
-> Indexed i a (Const (Deepening i a) b)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Const (Deepening i a) b)
 -> Indexed i a (Const (Deepening i a) b))
-> (i -> a -> Const (Deepening i a) b)
-> Indexed i a (Const (Deepening i a) b)
forall a b. (a -> b) -> a -> b
$ \ i
i -> (a -> Deepening i a) -> a -> Const (Deepening i a) b
forall (p :: * -> * -> *) a b x.
Profunctor p =>
p a b -> p a (Const b x)
rmapConst (i -> a -> Deepening i a
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 Int -> [Level i a] -> [Level i a]
forall a b. a -> b -> b
`seq` Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
forall i a.
Deepening i a -> forall r. Int -> (Level i a -> Bool -> r) -> r
runDeepening Deepening i a
z Int
k ((Level i a -> Bool -> [Level i a]) -> [Level i a])
-> (Level i a -> Bool -> [Level i a]) -> [Level i a]
forall a b. (a -> b) -> a -> b
$ \ Level i a
xs Bool
b ->
    Level i a
xs Level i a -> [Level i a] -> [Level i a]
forall a. a -> [a] -> [a]
: if Bool
b then (Int -> Deepening i a -> [Level i a]
go (Int -> Deepening i a -> [Level i a])
-> Int -> Deepening i a -> [Level i a]
forall a b. (a -> b) -> a -> b
$! Int
k Int -> Int -> Int
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 = Flows j b t -> [Level j b] -> t
forall i b a. Flows i b a -> [Level i b] -> a
runFlows (Flows j b t -> [Level j b] -> t)
-> Flows j b t -> [Level j b] -> t
forall a b. (a -> b) -> a -> b
$ BazaarT (Indexed i) f a b t
-> forall (f :: * -> *). Applicative f => Indexed i a (f b) -> f t
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 (Indexed i a (Flows j b b) -> Flows j b t)
-> Indexed i a (Flows j b b) -> Flows j b t
forall a b. (a -> b) -> a -> b
$ (i -> a -> Flows j b b) -> Indexed i a (Flows j b b)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Flows j b b) -> Indexed i a (Flows j b b))
-> (i -> a -> Flows j b b) -> Indexed i a (Flows j b b)
forall a b. (a -> b) -> a -> b
$ \ i
_ a
_ -> ([Level j b] -> b) -> Flows j b b
forall i b a. ([Level i b] -> a) -> Flows i b a
Flows (([Level j b] -> b) -> Flows j b b)
-> ([Level j b] -> b) -> Flows j b b
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]
_           -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"ilevelOuts: wrong shape"
{-# INLINE ilevelOuts #-}

-- | This provides a breadth-first 'Traversal' or 'Fold' of the individual
-- levels of any other 'Traversal' or 'Fold' via iterative deepening depth-first
-- search. The levels are returned to you in a compressed format.
--
-- This is similar to 'levels', but retains the index of the original 'IndexedTraversal', so you can
-- access it when traversing the levels later on.
--
-- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed).itraversed
-- [((0,0),'d'),((0,1),'o'),((1,0),'c'),((0,2),'g'),((1,1),'a'),((1,2),'t')]
--
-- The resulting 'Traversal' of the levels which is indexed by the depth of each 'Level'.
--
-- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed)<.>itraversed
-- [((2,(0,0)),'d'),((3,(0,1)),'o'),((3,(1,0)),'c'),((4,(0,2)),'g'),((4,(1,1)),'a'),((5,(1,2)),'t')]
--
-- @
-- 'ilevels' :: 'IndexedTraversal' i s t a b      -> 'IndexedTraversal' 'Int' s t ('Level' i a) ('Level' i b)
-- 'ilevels' :: 'IndexedFold' i s a               -> 'IndexedFold' 'Int' s ('Level' i a)
-- @
--
-- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information
-- in an order that violates the 'Applicative' laws.
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 = BazaarT (Indexed i) f a b t -> [Level j b] -> t
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 ([Level j b] -> t) -> f [Level j b] -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p (Level i a) (f (Level j b)) -> [Level i a] -> f [Level j b]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal
  Int [Level i a] [Level j b] (Level i a) (Level j b)
traversed p (Level i a) (f (Level j b))
f (BazaarT (Indexed i) f a b t -> [Level i a]
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 Indexed i a (BazaarT (Indexed i) f a b b)
forall a b. Indexed i a (BazaarT (Indexed i) f a b b)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell s
s
{-# INLINE ilevels #-}