{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe       #-}
-- |
-- Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals.
-- Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780
--
-- https://arxiv.org/abs/1805.06798
--
-- This is modified version of part of @generic-lens@ library
--
-- Copyright (c) 2018, Csongor Kiss
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
--
--     * Neither the name of Csongor Kiss nor the names of other
--       contributors may be used to endorse or promote products derived
--       from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
module Data.Functor.Confusing (
    fusing, confusing, LensLike,
    ifusing, iconfusing, IxLensLike,
    ffusing, fconfusing, FLensLike,
    liftCurriedYoneda, yap,
    Curried (..), liftCurried, lowerCurried,
    Yoneda (..), liftYoneda, lowerYoneda,
  ) where

import Control.Applicative

-------------------------------------------------------------------------------
-- Confusing
-------------------------------------------------------------------------------

type LensLike f s t a b = (a -> f b) -> s -> f t

-- note: qualified name to justify import even with newer GHCs

fusing :: Functor f => LensLike (Yoneda f) s t a b -> LensLike f s t a b
fusing :: LensLike (Yoneda f) s t a b -> LensLike f s t a b
fusing LensLike (Yoneda f) s t a b
t = \a -> f b
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  LensLike (Yoneda f) s t a b
t (f b -> Yoneda f b
forall (f :: * -> *) a. Functor f => f a -> Yoneda f a
liftYoneda (f b -> Yoneda f b) -> (a -> f b) -> a -> Yoneda f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)
{-# INLINE fusing #-}

confusing :: Control.Applicative.Applicative f => LensLike (Curried (Yoneda f)) s t a b -> LensLike f s t a b
confusing :: LensLike (Curried (Yoneda f)) s t a b -> LensLike f s t a b
confusing LensLike (Curried (Yoneda f)) s t a b
t = \a -> f b
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curried (Yoneda f) t -> Yoneda f t
forall (f :: * -> *) a. Applicative f => Curried f a -> f a
lowerCurried (Curried (Yoneda f) t -> Yoneda f t)
-> (s -> Curried (Yoneda f) t) -> s -> Yoneda f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike (Curried (Yoneda f)) s t a b
t (f b -> Curried (Yoneda f) b
forall (f :: * -> *) a.
Applicative f =>
f a -> Curried (Yoneda f) a
liftCurriedYoneda (f b -> Curried (Yoneda f) b)
-> (a -> f b) -> a -> Curried (Yoneda f) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)
{-# INLINE confusing #-}

liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
liftCurriedYoneda :: f a -> Curried (Yoneda f) a
liftCurriedYoneda f a
fa = (forall r. Yoneda f (a -> r) -> Yoneda f r) -> Curried (Yoneda f) a
forall (f :: * -> *) a.
(forall r. f (a -> r) -> f r) -> Curried f a
Curried (Yoneda f (a -> r) -> f a -> Yoneda f r
forall (f :: * -> *) a b.
Applicative f =>
Yoneda f (a -> b) -> f a -> Yoneda f b
`yap` f a
fa)
{-# INLINE liftCurriedYoneda #-}

yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
yap :: Yoneda f (a -> b) -> f a -> Yoneda f b
yap (Yoneda forall b. ((a -> b) -> b) -> f b
k) f a
fa = (forall b. (b -> b) -> f b) -> Yoneda f b
forall (f :: * -> *) a. (forall b. (a -> b) -> f b) -> Yoneda f a
Yoneda (\b -> b
ab_r -> ((a -> b) -> a -> b) -> f (a -> b)
forall b. ((a -> b) -> b) -> f b
k (b -> b
ab_r (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa)
{-# INLINE yap #-}

type IxLensLike f i s t a b = (i -> a -> f b) -> s -> f t

ifusing :: Functor f => IxLensLike (Yoneda f) i s t a b -> IxLensLike f i s t a b
ifusing :: IxLensLike (Yoneda f) i s t a b -> IxLensLike f i s t a b
ifusing IxLensLike (Yoneda f) i s t a b
t = \i -> a -> f b
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IxLensLike (Yoneda f) i s t a b
t (\i
i a
a -> f b -> Yoneda f b
forall (f :: * -> *) a. Functor f => f a -> Yoneda f a
liftYoneda (i -> a -> f b
f i
i a
a))
{-# INLINE ifusing #-}

iconfusing :: Applicative f => IxLensLike (Curried (Yoneda f)) i s t a b -> IxLensLike f i s t a b
iconfusing :: IxLensLike (Curried (Yoneda f)) i s t a b -> IxLensLike f i s t a b
iconfusing IxLensLike (Curried (Yoneda f)) i s t a b
t = \i -> a -> f b
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curried (Yoneda f) t -> Yoneda f t
forall (f :: * -> *) a. Applicative f => Curried f a -> f a
lowerCurried (Curried (Yoneda f) t -> Yoneda f t)
-> (s -> Curried (Yoneda f) t) -> s -> Yoneda f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IxLensLike (Curried (Yoneda f)) i s t a b
t (\i
i a
a -> f b -> Curried (Yoneda f) b
forall (f :: * -> *) a.
Applicative f =>
f a -> Curried (Yoneda f) a
liftCurriedYoneda (i -> a -> f b
f i
i a
a))
{-# INLINE iconfusing #-}

type FLensLike f s t a b = (forall x. a x -> f (b x)) -> s -> f t

ffusing :: Functor f => FLensLike (Yoneda f) s t a b -> FLensLike f s t a b
ffusing :: FLensLike (Yoneda f) s t a b -> FLensLike f s t a b
ffusing FLensLike (Yoneda f) s t a b
t = \forall x. a x -> f (b x)
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FLensLike (Yoneda f) s t a b
t (f (b x) -> Yoneda f (b x)
forall (f :: * -> *) a. Functor f => f a -> Yoneda f a
liftYoneda (f (b x) -> Yoneda f (b x))
-> (a x -> f (b x)) -> a x -> Yoneda f (b x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a x -> f (b x)
forall x. a x -> f (b x)
f)
{-# INLINE ffusing #-}

fconfusing :: Applicative f => FLensLike (Curried (Yoneda f)) s t a b -> FLensLike f s t a b
fconfusing :: FLensLike (Curried (Yoneda f)) s t a b -> FLensLike f s t a b
fconfusing FLensLike (Curried (Yoneda f)) s t a b
t = \forall x. a x -> f (b x)
f -> Yoneda f t -> f t
forall (f :: * -> *) a. Yoneda f a -> f a
lowerYoneda (Yoneda f t -> f t) -> (s -> Yoneda f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curried (Yoneda f) t -> Yoneda f t
forall (f :: * -> *) a. Applicative f => Curried f a -> f a
lowerCurried (Curried (Yoneda f) t -> Yoneda f t)
-> (s -> Curried (Yoneda f) t) -> s -> Yoneda f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FLensLike (Curried (Yoneda f)) s t a b
t (f (b x) -> Curried (Yoneda f) (b x)
forall (f :: * -> *) a.
Applicative f =>
f a -> Curried (Yoneda f) a
liftCurriedYoneda (f (b x) -> Curried (Yoneda f) (b x))
-> (a x -> f (b x)) -> a x -> Curried (Yoneda f) (b x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a x -> f (b x)
forall x. a x -> f (b x)
f)
{-# INLINE fconfusing #-}

-------------------------------------------------------------------------------
-- Curried
-------------------------------------------------------------------------------

newtype Curried f a = Curried { Curried f a -> forall r. f (a -> r) -> f r
runCurried :: forall r. f (a -> r) -> f r }

instance Functor f => Functor (Curried f) where
    fmap :: (a -> b) -> Curried f a -> Curried f b
fmap a -> b
f (Curried forall r. f (a -> r) -> f r
g) = (forall r. f (b -> r) -> f r) -> Curried f b
forall (f :: * -> *) a.
(forall r. f (a -> r) -> f r) -> Curried f a
Curried (f (a -> r) -> f r
forall r. f (a -> r) -> f r
g (f (a -> r) -> f r)
-> (f (b -> r) -> f (a -> r)) -> f (b -> r) -> f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> r) -> a -> r) -> f (b -> r) -> f (a -> r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
f))
    {-# INLINE fmap #-}

instance Functor f => Applicative (Curried f) where
    pure :: a -> Curried f a
pure a
a = (forall r. f (a -> r) -> f r) -> Curried f a
forall (f :: * -> *) a.
(forall r. f (a -> r) -> f r) -> Curried f a
Curried (((a -> r) -> r) -> f (a -> r) -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> r) -> a -> r
forall a b. (a -> b) -> a -> b
$ a
a))
    {-# INLINE pure #-}
    Curried forall r. f ((a -> b) -> r) -> f r
mf <*> :: Curried f (a -> b) -> Curried f a -> Curried f b
<*> Curried forall r. f (a -> r) -> f r
ma = (forall r. f (b -> r) -> f r) -> Curried f b
forall (f :: * -> *) a.
(forall r. f (a -> r) -> f r) -> Curried f a
Curried (f (a -> r) -> f r
forall r. f (a -> r) -> f r
ma (f (a -> r) -> f r)
-> (f (b -> r) -> f (a -> r)) -> f (b -> r) -> f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ((a -> b) -> a -> r) -> f (a -> r)
forall r. f ((a -> b) -> r) -> f r
mf (f ((a -> b) -> a -> r) -> f (a -> r))
-> (f (b -> r) -> f ((a -> b) -> a -> r))
-> f (b -> r)
-> f (a -> r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> r) -> (a -> b) -> a -> r)
-> f (b -> r) -> f ((a -> b) -> a -> r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.))
    {-# INLINE (<*>) #-}

liftCurried :: Applicative f => f a -> Curried f a
liftCurried :: f a -> Curried f a
liftCurried f a
fa = (forall r. f (a -> r) -> f r) -> Curried f a
forall (f :: * -> *) a.
(forall r. f (a -> r) -> f r) -> Curried f a
Curried (f (a -> r) -> f a -> f r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa)

lowerCurried :: Applicative f => Curried f a -> f a
lowerCurried :: Curried f a -> f a
lowerCurried (Curried forall r. f (a -> r) -> f r
f) = f (a -> a) -> f a
forall r. f (a -> r) -> f r
f ((a -> a) -> f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id)

-------------------------------------------------------------------------------
-- Yoneda
-------------------------------------------------------------------------------

newtype Yoneda f a = Yoneda { Yoneda f a -> forall b. (a -> b) -> f b
runYoneda :: forall b. (a -> b) -> f b }

liftYoneda :: Functor f => f a -> Yoneda f a
liftYoneda :: f a -> Yoneda f a
liftYoneda f a
a = (forall b. (a -> b) -> f b) -> Yoneda f a
forall (f :: * -> *) a. (forall b. (a -> b) -> f b) -> Yoneda f a
Yoneda (\a -> b
f -> (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
a)

lowerYoneda :: Yoneda f a -> f a
lowerYoneda :: Yoneda f a -> f a
lowerYoneda (Yoneda forall b. (a -> b) -> f b
f) = (a -> a) -> f a
forall b. (a -> b) -> f b
f a -> a
forall a. a -> a
id

instance Functor (Yoneda f) where
    fmap :: (a -> b) -> Yoneda f a -> Yoneda f b
fmap a -> b
f Yoneda f a
m = (forall b. (b -> b) -> f b) -> Yoneda f b
forall (f :: * -> *) a. (forall b. (a -> b) -> f b) -> Yoneda f a
Yoneda (\b -> b
k -> Yoneda f a -> (a -> b) -> f b
forall (f :: * -> *) a. Yoneda f a -> forall b. (a -> b) -> f b
runYoneda Yoneda f a
m (b -> b
k (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative f => Applicative (Yoneda f) where
    pure :: a -> Yoneda f a
pure a
a = (forall b. (a -> b) -> f b) -> Yoneda f a
forall (f :: * -> *) a. (forall b. (a -> b) -> f b) -> Yoneda f a
Yoneda (\a -> b
f -> b -> f b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a))
    Yoneda forall b. ((a -> b) -> b) -> f b
m <*> :: Yoneda f (a -> b) -> Yoneda f a -> Yoneda f b
<*> Yoneda forall b. (a -> b) -> f b
n = (forall b. (b -> b) -> f b) -> Yoneda f b
forall (f :: * -> *) a. (forall b. (a -> b) -> f b) -> Yoneda f a
Yoneda (\b -> b
f -> ((a -> b) -> a -> b) -> f (a -> b)
forall b. ((a -> b) -> b) -> f b
m (b -> b
f (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> a) -> f a
forall b. (a -> b) -> f b
n a -> a
forall a. a -> a
id)