{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeFamilyDependencies    #-}
{-# LANGUAGE TypeOperators             #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Internal.Profunctor.Lens
-- Copyright   :  (C) 2020 Csongor Kiss
-- License     :  BSD3
-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Internal lens helpers. Only exported for Haddock
--
-----------------------------------------------------------------------------
module Data.Generics.Internal.Profunctor.Lens where

import Data.Profunctor.Indexed        (Profunctor(..), Strong(..))
import Data.Bifunctor
import GHC.Generics
import Data.Generics.Internal.Profunctor.Iso

type Lens s t a b
  = forall p i . Strong p => p i a b -> p i s t

type LensLike p s t a b
  = p a b -> p s t


ravel :: (ALens a b i a b -> ALens a b i s t) -> Lens s t a b
ravel l pab = conv (l idLens) pab
  where
    conv :: ALens a b i s t -> Lens s t a b
    conv (ALens _get _set) = lens _get _set

-- | Setting
set :: ((a -> b) -> s -> t) -> (s, b) -> t
set f (s, b)
  = f  (const b) s

view :: Lens s s a a -> s -> a
view l = withLensPrim l (\get _ -> snd . get)

--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
--ithLens l k =
-- case l idLens of
--   ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))

withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
withLensPrim l k =
 case l idLens of
   ALens _get _set -> k _get _set

idLens :: ALens a b i a b
idLens = ALens (fork (const ()) id) snd
{-# INLINE idLens #-}

-- | Lens focusing on the first element of a product
first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
first
  = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)

-- | Lens focusing on the second element of a product
second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
second
  = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')

fork :: (a -> b) -> (a -> c) -> a -> (b, c)
fork f g a = (f a, g a)

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

data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)

instance Functor (Coyoneda f) where
  fmap f (Coyoneda g fa)
    = Coyoneda (f . g) fa

inj :: Functor f => Coyoneda f a -> f a
inj (Coyoneda f a) = fmap f a

proj :: Functor f => f a -> Coyoneda f a
proj fa = Coyoneda id fa

(??) :: Functor f => f (a -> b) -> a -> f b
fab ?? a = fmap ($ a) fab

assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
assoc3L f = assoc3 f

stron :: (Either s s', b) -> Either (s, b) (s', b)
stron (e, b) =  bimap (,b) (, b) e

choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
choosing l r = withLensPrim l (\getl setl ->
                  withLensPrim r (\getr setr ->
                            let --g :: Either s s' -> a
                                g e = case e of
                                        Left v -> let (c, v') = getl v in (Left c, v')
                                        Right v -> let (c, v') = getr v in (Right c, v')
                                s = bimap setl setr . stron
                            in lens g s))

lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
lens get _set = dimap get _set . second'
{-# INLINE lens #-}

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

data ALens a b i s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)

instance Functor (ALens a b i s) where
  fmap f (ALens _get _set) = ALens _get (f . _set)

instance Profunctor (ALens a b) where
  dimap f g (ALens get _set) = ALens (get . f) (g . _set)
  lmap f = dimap f id
  rmap f = dimap id f

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)

instance Strong (ALens a b) where
  first' = dimap swap swap . second'
  {-# INLINE first' #-}
  second' (ALens get _set) = ALens get' set'
    where
      get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
      set' ((c, c1), b) = (c, _set (c1, b))
  {-# INLINE second' #-}