{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Internal implementation details of indexed optics.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Optics.Internal.Indexed where

import Data.Kind (Type)
import GHC.TypeLits

import Data.Profunctor.Indexed
import Optics.Internal.Optic

-- | Show useful error message when a function expects optics without indices.
class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: IxList)

instance
  ( TypeError
    ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no indices")
  , (x ': xs) ~ NoIx
  ) => AcceptsEmptyIndices f (x ': xs)

instance AcceptsEmptyIndices f '[]

-- | Check whether a list of indices is not empty and generate sensible error
-- message if it's not.
class NonEmptyIndices (is :: IxList)

instance
  ( TypeError
    ('Text "Indexed optic is expected")
  ) => NonEmptyIndices '[]

instance NonEmptyIndices (x ': xs)

-- | Generate sensible error messages in case a user tries to pass either an
-- unindexed optic or indexed optic with unflattened indices where indexed optic
-- with a single index is expected.
class is ~ '[i] => HasSingleIndex (is :: IxList) (i :: Type)

instance HasSingleIndex '[i] i

instance
  ( TypeError
    ('Text "Indexed optic is expected")
  , '[] ~ '[i]
  ) => HasSingleIndex '[] i

instance
  ( TypeError
    ('Text "Use (<%>) or icompose to combine indices of type "
     ':<>: ShowTypes is)
  , is ~ '[i1, i2]
  , is ~ '[i]
  ) => HasSingleIndex '[i1, i2] i

instance
  ( TypeError
    ('Text "Use icompose3 to combine indices of type "
     ':<>: ShowTypes is)
  , is ~ '[i1, i2, i3]
  , is ~ '[i]
  ) => HasSingleIndex [i1, i2, i3] i

instance
  ( TypeError
    ('Text "Use icompose4 to combine indices of type "
     ':<>: ShowTypes is)
  , is ~ '[i1, i2, i3, i4]
  , is ~ '[i]
  ) => HasSingleIndex '[i1, i2, i3, i4] i

instance
  ( TypeError
    ('Text "Use icompose5 to flatten indices of type "
     ':<>: ShowTypes is)
  , is ~ '[i1, i2, i3, i4, i5]
  , is ~ '[i]
  ) => HasSingleIndex '[i1, i2, i3, i4, i5] i

instance
  ( TypeError
    ('Text "Use icomposeN to flatten indices of type "
     ':<>: ShowTypes is)
  , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is')
  , is ~ '[i]
  ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i

----------------------------------------
-- Helpers for HasSingleIndex

type family ShowTypes (types :: [Type]) :: ErrorMessage where
  ShowTypes '[i]      = QuoteType i
  ShowTypes '[i, j]   = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j
  ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is

----------------------------------------

data IntT f a = IntT {-# UNPACK #-} !Int (f a)

unIntT :: IntT f a -> f a
unIntT :: IntT f a -> f a
unIntT (IntT Int
_ f a
fa) = f a
fa

newtype Indexing f a = Indexing { Indexing f a -> Int -> IntT f a
runIndexing :: Int -> IntT f a }

instance Functor f => Functor (Indexing f) where
  fmap :: (a -> b) -> Indexing f a -> Indexing f b
fmap a -> b
f (Indexing Int -> IntT f a
m) = (Int -> IntT f b) -> Indexing f b
forall k (f :: k -> *) (a :: k). (Int -> IntT f a) -> Indexing f a
Indexing ((Int -> IntT f b) -> Indexing f b)
-> (Int -> IntT f b) -> Indexing f b
forall a b. (a -> b) -> a -> b
$ \Int
i -> case Int -> IntT f a
m Int
i of
    IntT Int
j f a
x -> Int -> f b -> IntT f b
forall k (f :: k -> *) (a :: k). Int -> f a -> IntT f a
IntT Int
j ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x)

instance Applicative f => Applicative (Indexing f) where
  pure :: a -> Indexing f a
pure a
x = (Int -> IntT f a) -> Indexing f a
forall k (f :: k -> *) (a :: k). (Int -> IntT f a) -> Indexing f a
Indexing ((Int -> IntT f a) -> Indexing f a)
-> (Int -> IntT f a) -> Indexing f a
forall a b. (a -> b) -> a -> b
$ \Int
i -> Int -> f a -> IntT f a
forall k (f :: k -> *) (a :: k). Int -> f a -> IntT f a
IntT Int
i (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  Indexing Int -> IntT f (a -> b)
mf <*> :: Indexing f (a -> b) -> Indexing f a -> Indexing f b
<*> Indexing Int -> IntT f a
ma = (Int -> IntT f b) -> Indexing f b
forall k (f :: k -> *) (a :: k). (Int -> IntT f a) -> Indexing f a
Indexing ((Int -> IntT f b) -> Indexing f b)
-> (Int -> IntT f b) -> Indexing f b
forall a b. (a -> b) -> a -> b
$ \Int
i -> case Int -> IntT f (a -> b)
mf Int
i of
    IntT Int
j f (a -> b)
ff -> case Int -> IntT f a
ma Int
j of
       IntT Int
k f a
fa -> Int -> f b -> IntT f b
forall k (f :: k -> *) (a :: k). Int -> f a -> IntT f a
IntT Int
k (f (a -> b)
ff f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa)

-- | Index a traversal by position of visited elements.
indexing
  :: ((a -> Indexing f b) -> s -> Indexing f t)
  -> ((Int -> a -> f b) -> s -> f t)
indexing :: ((a -> Indexing f b) -> s -> Indexing f t)
-> (Int -> a -> f b) -> s -> f t
indexing (a -> Indexing f b) -> s -> Indexing f t
l Int -> a -> f b
iafb s
s =
  IntT f t -> f t
forall k (f :: k -> *) (a :: k). IntT f a -> f a
unIntT (IntT f t -> f t) -> IntT f t -> f t
forall a b. (a -> b) -> a -> b
$ Indexing f t -> Int -> IntT f t
forall k (f :: k -> *) (a :: k). Indexing f a -> Int -> IntT f a
runIndexing ((a -> Indexing f b) -> s -> Indexing f t
l (\a
a -> (Int -> IntT f b) -> Indexing f b
forall k (f :: k -> *) (a :: k). (Int -> IntT f a) -> Indexing f a
Indexing (\Int
i -> Int -> f b -> IntT f b
forall k (f :: k -> *) (a :: k). Int -> f a -> IntT f a
IntT (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> a -> f b
iafb Int
i a
a))) s
s) Int
0

----------------------------------------

-- | Construct a conjoined indexed optic that provides a separate code path when
-- used without indices. Useful for defining indexed optics that are as
-- efficient as their unindexed equivalents when used without indices.
--
-- /Note:/ @'conjoined' f g@ is well-defined if and only if @f ≡
-- 'Optics.Indexed.Core.noIx' g@.
conjoined
  :: is `HasSingleIndex` i
  => Optic k NoIx s t a b
  -> Optic k is   s t a b
  -> Optic k is   s t a b
conjoined :: Optic k NoIx s t a b -> Optic k is s t a b -> Optic k is s t a b
conjoined (Optic forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ k p i (Curry NoIx i) s t a b
f) (Optic forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ k p i (Curry is i) s t a b
g) = (forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ k p i (Curry is i) s t a b)
-> Optic k is s t a b
forall k (is :: IxList) s t a b.
(forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ k p i (Curry is i) s t a b)
-> Optic k is s t a b
Optic ((p i a b -> p i s t)
-> (p i a b -> p (i -> i) s t) -> p i a b -> p (i -> i) s t
forall (p :: * -> * -> * -> *) i a b s t j.
Profunctor p =>
(p i a b -> p i s t) -> (p i a b -> p j s t) -> p i a b -> p j s t
conjoined__ p i a b -> p i s t
forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ k p i (Curry NoIx i) s t a b
f p i a b -> p (i -> i) s t
forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ k p i (Curry is i) s t a b
g)