{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Control.Selective.Free
-- Copyright  : (c) Andrey Mokhov 2018-2023
-- 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://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf.
--
-- 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 (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
x forall x. f x -> g x
k

instance Applicative (Select f) where
    pure :: forall a. a -> Select f a
pure a
a                = forall (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
_ -> 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 (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
x forall x. f x -> g x
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
y 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 (f :: * -> *) a.
(forall (g :: * -> *).
 Selective g =>
 (forall x. f x -> g x) -> g a)
-> Select f a
Select forall a b. (a -> b) -> a -> b
$ \forall x. f x -> g x
k -> forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (Either a b)
x forall x. f x -> g x
k forall (f :: * -> *) a b.
Selective f =>
f (Either a b) -> f (a -> b) -> f b
<*? forall (g :: * -> *).
Selective g =>
(forall x. f x -> g x) -> g (a -> b)
y 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 (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 -> 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 (g :: * -> *). Selective g => (forall x. f x -> g x) -> g a
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 = forall m a. Over m a -> m
getOver forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect (forall m a. m -> Over m a
Over forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect (forall a b. a -> b -> a
const 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 m (f :: * -> *) a.
Monoid m =>
(forall x. f x -> m) -> Select f a -> m
foldSelect (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall m a. Under m a -> m
getUnder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect (forall m a. m -> Under m a
Under forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void)