{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.RAVec.Tree.Optics (
    -- * Indexing
    ix,
    ) where

import Control.Applicative ((<$>))
import Data.Wrd            (Wrd (..))
import Prelude             (Functor)

import qualified Optics.Core as L

import Data.RAVec.Tree

-- $setup
-- >>> import Optics.Core (set)
-- >>> import Prelude
-- >>> import Data.RAVec.Tree
-- >>> import Data.Wrd (Wrd (..))

type LensLikeVL f s t a b = (a -> f b) -> s -> f t
type LensLikeVL' f s a = LensLikeVL f s s a a

-------------------------------------------------------------------------------
-- Indexing
-------------------------------------------------------------------------------

-- | Index lens.
--
-- >>> let tree = Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'c') (Leaf 'd'))
-- >>> set (ix (W1 $ W0 WE)) 'z' tree
-- Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'z') (Leaf 'd'))
--
ix :: Wrd n -> L.Lens' (Tree n a) a
ix :: forall (n :: Nat) a. Wrd n -> Lens' (Tree n a) a
ix Wrd n
i = LensVL (Tree n a) (Tree n a) a a -> Lens (Tree n a) (Tree n a) a a
forall s t a b. LensVL s t a b -> Lens s t a b
L.lensVL (Wrd n -> LensLikeVL' f (Tree n a) a
forall (f :: * -> *) (n :: Nat) a.
Functor f =>
Wrd n -> LensLikeVL' f (Tree n a) a
ixVL Wrd n
i)

ixVL :: Functor f => Wrd n -> LensLikeVL' f (Tree n a) a
ixVL :: forall (f :: * -> *) (n :: Nat) a.
Functor f =>
Wrd n -> LensLikeVL' f (Tree n a) a
ixVL Wrd n
WE      a -> f a
f (Leaf a
x)   = a -> Tree n a
a -> Tree 'Z a
forall a. a -> Tree 'Z a
Leaf (a -> Tree n a) -> f a -> f (Tree n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
x
ixVL (W0 Wrd n1
is) a -> f a
f (Node Tree n1 a
x Tree n1 a
y) = (Tree n1 a -> Tree n1 a -> Tree ('S n1) a
forall (n1 :: Nat) a. Tree n1 a -> Tree n1 a -> Tree ('S n1) a
`Node` Tree n1 a
y) (Tree n1 a -> Tree n a) -> f (Tree n1 a) -> f (Tree n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wrd n1 -> LensLikeVL' f (Tree n1 a) a
forall (f :: * -> *) (n :: Nat) a.
Functor f =>
Wrd n -> LensLikeVL' f (Tree n a) a
ixVL Wrd n1
Wrd n1
is a -> f a
f Tree n1 a
x
ixVL (W1 Wrd n1
is) a -> f a
f (Node Tree n1 a
x Tree n1 a
y) = (Tree n1 a
x Tree n1 a -> Tree n1 a -> Tree ('S n1) a
forall (n1 :: Nat) a. Tree n1 a -> Tree n1 a -> Tree ('S n1) a
`Node`) (Tree n1 a -> Tree n a) -> f (Tree n1 a) -> f (Tree n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wrd n1 -> LensLikeVL' f (Tree n1 a) a
forall (f :: * -> *) (n :: Nat) a.
Functor f =>
Wrd n -> LensLikeVL' f (Tree n a) a
ixVL Wrd n1
Wrd n1
is a -> f a
f Tree n1 a
y

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

instance L.Each (Wrd n) (Tree n a) (Tree n b) a b where

type instance L.Index (Tree n a)   = Wrd n
type instance L.IxValue (Tree n a) = a

instance L.Ixed (Tree n a) where
    type IxKind (Tree n a) = L.A_Lens
    ix :: Index (Tree n a)
-> Optic' (IxKind (Tree n a)) NoIx (Tree n a) (IxValue (Tree n a))
ix = Wrd n -> Lens' (Tree n a) a
Index (Tree n a)
-> Optic' (IxKind (Tree n a)) NoIx (Tree n a) (IxValue (Tree n a))
forall (n :: Nat) a. Wrd n -> Lens' (Tree n a) a
ix