{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Control.Selective.Free
-- Copyright  : (c) Andrey Mokhov 2018-2024
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- This is a library for /selective applicative functors/, or just
-- /selective functors/ for short, an abstraction between applicative functors
-- and monads, introduced in this paper: https://dl.acm.org/doi/10.1145/3341694.
--
-- This module defines /free selective functors/ using the ideas from the
-- Sjoerd Visscher's package 'free-functors':
-- https://hackage.haskell.org/package/free-functors-1.0.1/docs/Data-Functor-HFree.html.
--
-----------------------------------------------------------------------------
module Control.Selective.Free (
    -- * Free selective functors
    Select (..), liftSelect,

    -- * Static analysis
    getPure, getEffects, getNecessaryEffects, runSelect, foldSelect
    ) where

import Control.Selective
import Data.Functor

-- | Free selective functors.
newtype Select f a = Select (forall g. Selective g => (forall x. f x -> g x) -> g a)

-- Ignoring the hint, since GHC can't type check the suggested code.
{-# ANN module "HLint: ignore Use fmap" #-}
instance Functor (Select f) where
    fmap :: forall a b. (a -> b) -> Select f a -> Select f b
fmap a -> b
f (Select forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
x) = (forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g b)
-> Select f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select ((forall (g :: * -> *).
  Selective g =>
  (forall x. f x -> g x) -> g b)
 -> Select f b)
-> (forall (g :: * -> *).
    Selective g =>
    (forall x. f x -> g x) -> g b)
-> Select f b
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> a -> b
f (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. f x -> g x) -> g a
forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
x f x -> g x
forall x. f x -> g x
k

instance Applicative (Select f) where
    pure :: forall a. a -> Select f a
pure a
a                = (forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select ((forall (g :: * -> *).
  Selective g =>
  (forall x. f x -> g x) -> g a)
 -> Select f a)
-> (forall (g :: * -> *).
    Selective g =>
    (forall x. f x -> g x) -> g a)
-> Select f a
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
_ -> a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Select forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
x <*> :: forall a b. Select f (a -> b) -> Select f a -> Select f b
<*> Select forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
y = (forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g b)
-> Select f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select ((forall (g :: * -> *).
  Selective g =>
  (forall x. f x -> g x) -> g b)
 -> Select f b)
-> (forall (g :: * -> *).
    Selective g =>
    (forall x. f x -> g x) -> g b)
-> Select f b
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> (forall x. f x -> g x) -> g (a -> b)
forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
x f x -> g x
forall x. f x -> g x
k g (a -> b) -> g a -> g b
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> g x) -> g a
forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
y f x -> g x
forall x. f x -> g x
k

instance Selective (Select f) where
    select :: forall a b.
Select f (Either a b) -> Select f (a -> b) -> Select f b
select (Select forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (Either a b)
x) (Select forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
y) = (forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g b)
-> Select f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select ((forall (g :: * -> *).
  Selective g =>
  (forall x. f x -> g x) -> g b)
 -> Select f b)
-> (forall (g :: * -> *).
    Selective g =>
    (forall x. f x -> g x) -> g b)
-> Select f b
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> (forall x. f x -> g x) -> g (Either a b)
forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (Either a b)
x f x -> g x
forall x. f x -> g x
k g (Either a b) -> g (a -> b) -> g b
forall (f :: * -> *) a b.
Selective f =>
f (Either a b) -> f (a -> b) -> f b
<*? (forall x. f x -> g x) -> g (a -> b)
forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
y f x -> g x
forall x. f x -> g x
k

-- | Lift a functor into a free selective computation.
liftSelect :: f a -> Select f a
liftSelect :: forall (f :: * -> *) a. f a -> Select f a
liftSelect f a
x = (forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select (\forall x. f x -> g x
f -> f a -> g a
forall x. f x -> g x
f f a
x)

-- | Given a natural transformation from @f@ to @g@, this gives a canonical
-- natural transformation from @Select f@ to @g@. Note that here we rely on the
-- fact that @g@ is a lawful selective functor.
runSelect :: Selective g => (forall x. f x -> g x) -> Select f a -> g a
runSelect :: forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect forall x. f x -> g x
k (Select forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
x) = (forall x. f x -> g x) -> g a
forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
x f x -> g x
forall x. f x -> g x
k

-- | Concatenate all effects of a free selective computation.
foldSelect :: Monoid m => (forall x. f x -> m) -> Select f a -> m
foldSelect :: forall m (f :: * -> *) a.
Monoid m =>
(forall x. f x -> m) -> Select f a -> m
foldSelect forall x. f x -> m
f = Over m a -> m
forall m a. Over m a -> m
getOver (Over m a -> m) -> (Select f a -> Over m a) -> Select f a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. f x -> Over m x) -> Select f a -> Over m a
forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect (m -> Over m x
forall m a. m -> Over m a
Over (m -> Over m x) -> (f x -> m) -> f x -> Over m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> m
forall x. f x -> m
f)

-- | Extract the resulting value if there are no necessary effects.
getPure :: Select f a -> Maybe a
getPure :: forall (f :: * -> *) a. Select f a -> Maybe a
getPure = (forall x. f x -> Maybe x) -> Select f a -> Maybe a
forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect (Maybe x -> f x -> Maybe x
forall a b. a -> b -> a
const Maybe x
forall a. Maybe a
Nothing)

-- | Collect /all possible effects/ in the order they appear in a free selective
-- computation.
getEffects :: Functor f => Select f a -> [f ()]
getEffects :: forall (f :: * -> *) a. Functor f => Select f a -> [f ()]
getEffects = (forall x. f x -> [f ()]) -> Select f a -> [f ()]
forall m (f :: * -> *) a.
Monoid m =>
(forall x. f x -> m) -> Select f a -> m
foldSelect (f () -> [f ()]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f () -> [f ()]) -> (f x -> f ()) -> f x -> [f ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void)

-- | Extract /all necessary effects/ in the order they appear in a free
-- selective computation.
getNecessaryEffects :: Functor f => Select f a -> [f ()]
getNecessaryEffects :: forall (f :: * -> *) a. Functor f => Select f a -> [f ()]
getNecessaryEffects = Under [f ()] a -> [f ()]
forall m a. Under m a -> m
getUnder (Under [f ()] a -> [f ()])
-> (Select f a -> Under [f ()] a) -> Select f a -> [f ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. f x -> Under [f ()] x) -> Select f a -> Under [f ()] a
forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect ([f ()] -> Under [f ()] x
forall m a. m -> Under m a
Under ([f ()] -> Under [f ()] x)
-> (f x -> [f ()]) -> f x -> Under [f ()] x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f () -> [f ()]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f () -> [f ()]) -> (f x -> f ()) -> f x -> [f ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void)