module Proton.Algebraic
    ( MStrong(..)
    , AlgebraicLens
    , AlgebraicLens'
    , algebraic
    , listLens
    , altLens
    , (>-)
    , (?.)
    ) where

import Data.Profunctor
import Data.Profunctor.MStrong
import Proton.Types
import Data.Monoid
import Control.Applicative
import Control.Arrow

type AlgebraicLens s t a b = forall p. MStrong p => p a b -> p s t
type AlgebraicLens' s a = AlgebraicLens s s a a

algebraic :: forall m p s t a b
           . (Monoid m,  MStrong p)
           => (s -> m)
           -> (s -> a)
           -> (m -> b -> t)
           -> Optic p s t a b
algebraic :: (s -> m) -> (s -> a) -> (m -> b -> t) -> Optic p s t a b
algebraic inject :: s -> m
inject project :: s -> a
project flatten :: m -> b -> t
flatten p :: p a b
p
  = (s -> (m, s)) -> ((m, b) -> t) -> p (m, s) (m, b) -> p s t
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (s -> m
inject (s -> m) -> (s -> s) -> s -> (m, s)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& s -> s
forall a. a -> a
id)  ((m -> b -> t) -> (m, b) -> t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry m -> b -> t
flatten) (p (m, s) (m, b) -> p s t) -> p (m, s) (m, b) -> p s t
forall a b. (a -> b) -> a -> b
$  p (m, s) (m, b)
strengthened
  where
    strengthened :: p (m, s) (m, b)
    strengthened :: p (m, s) (m, b)
strengthened = p s b -> p (m, s) (m, b)
forall (p :: * -> * -> *) m a b.
(MStrong p, Monoid m) =>
p a b -> p (m, a) (m, b)
msecond' ((s -> a) -> p a b -> p s b
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap s -> a
project p a b
p)

listLens :: MStrong p => (s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens :: (s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens = (s -> [s]) -> (s -> a) -> ([s] -> b -> t) -> Optic p s t a b
forall m (p :: * -> * -> *) s t a b.
(Monoid m, MStrong p) =>
(s -> m) -> (s -> a) -> (m -> b -> t) -> Optic p s t a b
algebraic s -> [s]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

altLens :: (Alternative f, MStrong p) => (s -> a) -> (f s -> b -> t) -> Optic p s t a b
altLens :: (s -> a) -> (f s -> b -> t) -> Optic p s t a b
altLens project :: s -> a
project flatten :: f s -> b -> t
flatten = (s -> Alt f s)
-> (s -> a) -> (Alt f s -> b -> t) -> Optic p s t a b
forall m (p :: * -> * -> *) s t a b.
(Monoid m, MStrong p) =>
(s -> m) -> (s -> a) -> (m -> b -> t) -> Optic p s t a b
algebraic (f s -> Alt f s
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (f s -> Alt f s) -> (s -> f s) -> s -> Alt f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure)  s -> a
project (f s -> b -> t
flatten (f s -> b -> t) -> (Alt f s -> f s) -> Alt f s -> b -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt f s -> f s
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt)

infixr 4 ?.
(?.) :: Optic (Costar f) s t a b -> b -> f s -> t
?. :: Optic (Costar f) s t a b -> b -> f s -> t
(?.) opt :: Optic (Costar f) s t a b
opt b :: b
b xs :: f s
xs = (Costar f s t -> f s -> t
forall (f :: * -> *) d c. Costar f d c -> f d -> c
runCostar (Costar f s t -> f s -> t) -> Costar f s t -> f s -> t
forall a b. (a -> b) -> a -> b
$ Optic (Costar f) s t a b
opt ((f a -> b) -> Costar f a b
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar (b -> f a -> b
forall a b. a -> b -> a
const b
b))) f s
xs

infixr 4 >-
(>-) :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
>- :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
(>-) opt :: Optic (Costar f) s t a b
opt aggregator :: f a -> b
aggregator xs :: f s
xs = (Costar f s t -> f s -> t
forall (f :: * -> *) d c. Costar f d c -> f d -> c
runCostar (Costar f s t -> f s -> t) -> Costar f s t -> f s -> t
forall a b. (a -> b) -> a -> b
$ Optic (Costar f) s t a b
opt ((f a -> b) -> Costar f a b
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar f a -> b
aggregator)) f s
xs