{-# LANGUAGE TemplateHaskell #-}

module Polysemy.View
  ( -- * Effect
    View (..)

    -- * Actions
  , see

    -- * Interpretations
  , viewToState
  , viewToInput
  ) where

import Polysemy
import Polysemy.Input
import Polysemy.State
import Polysemy.Tagged


------------------------------------------------------------------------------
-- | A 'View' is an expensive computation that should be cached.
data View v m a where
  See :: View v m v

makeSem ''View


------------------------------------------------------------------------------
-- | Transform a 'View' into an 'Input'.
viewToInput
    :: forall v i r a
     . Member (Input i) r
    => (i -> v)
    -> Sem (View v ': r) a
    -> Sem r a
viewToInput :: (i -> v) -> Sem (View v : r) a -> Sem r a
viewToInput i -> v
f = (forall (rInitial :: EffectRow) x.
 View v (Sem rInitial) x -> Sem r x)
-> Sem (View v : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  View v (Sem rInitial) x -> Sem r x)
 -> Sem (View v : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    View v (Sem rInitial) x -> Sem r x)
-> Sem (View v : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  View v (Sem rInitial) x
See -> i -> v
f (i -> v) -> Sem r i -> Sem r v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r i
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input


------------------------------------------------------------------------------
-- | Get a 'View' as an exensive computation over an underlying 'State' effect.
-- This 'View' is only invalidated when the underlying 'State' changes.
viewToState
    :: forall v s r a
     . Member (State s) r
    => (s -> Sem r v)
    -> Sem (View v ': r) a
    -> Sem r a
viewToState :: (s -> Sem r v) -> Sem (View v : r) a -> Sem r a
viewToState s -> Sem r v
f = do
  Cached v -> Sem (State (Cached v) : r) a -> Sem r a
forall s (r :: EffectRow) a. s -> Sem (State s : r) a -> Sem r a
evalState Cached v
forall a. Cached a
Dirty
    (Sem (State (Cached v) : r) a -> Sem r a)
-> (Sem (View v : r) a -> Sem (State (Cached v) : r) a)
-> Sem (View v : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Sem (Tagged "view" (State (Cached v)) : r) a
-> Sem (State (Cached v) : r) a
forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag @"view" @(State (Cached v))
    (Sem (Tagged "view" (State (Cached v)) : r) a
 -> Sem (State (Cached v) : r) a)
-> (Sem (View v : r) a
    -> Sem (Tagged "view" (State (Cached v)) : r) a)
-> Sem (View v : r) a
-> Sem (State (Cached v) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x (rInitial :: EffectRow).
 State s (Sem rInitial) x
 -> Sem (Tagged "view" (State (Cached v)) : r) x)
-> Sem (Tagged "view" (State (Cached v)) : r) a
-> Sem (Tagged "view" (State (Cached v)) : r) a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept @(State s)
      ( \case
        State s (Sem rInitial) x
Get -> Sem (Tagged "view" (State (Cached v)) : r) x
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
        Put s
s -> do
          s -> Sem (Tagged "view" (State (Cached v)) : r) ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put s
s
          forall (r :: EffectRow) a.
Member (Tagged "view" (State (Cached v))) r =>
Sem (State (Cached v) : r) a -> Sem r a
forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Tagged k2 e) r =>
Sem (e : r) a -> Sem r a
tag @"view" @(State (Cached v)) (Sem (State (Cached v) : Tagged "view" (State (Cached v)) : r) ()
 -> Sem (Tagged "view" (State (Cached v)) : r) ())
-> Sem (State (Cached v) : Tagged "view" (State (Cached v)) : r) ()
-> Sem (Tagged "view" (State (Cached v)) : r) ()
forall a b. (a -> b) -> a -> b
$ Cached v
-> Sem (State (Cached v) : Tagged "view" (State (Cached v)) : r) ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put (Cached v
 -> Sem
      (State (Cached v) : Tagged "view" (State (Cached v)) : r) ())
-> Cached v
-> Sem (State (Cached v) : Tagged "view" (State (Cached v)) : r) ()
forall a b. (a -> b) -> a -> b
$ Cached v
forall a. Cached a
Dirty @v
      )
    (Sem (Tagged "view" (State (Cached v)) : r) a
 -> Sem (Tagged "view" (State (Cached v)) : r) a)
-> (Sem (View v : r) a
    -> Sem (Tagged "view" (State (Cached v)) : r) a)
-> Sem (View v : r) a
-> Sem (Tagged "view" (State (Cached v)) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (rInitial :: EffectRow) x.
 View v (Sem rInitial) x
 -> Sem (Tagged "view" (State (Cached v)) : r) x)
-> Sem (View v : r) a
-> Sem (Tagged "view" (State (Cached v)) : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret @(View v)
      ( \case
          View v (Sem rInitial) x
See -> do
            Cached v
dirty <- forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e : r) a -> Sem (Tagged k2 e : r) a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e : r) a -> Sem (Tagged "view" e : r) a
tagged @"view" (Sem (State (Cached v) : r) (Cached v)
 -> Sem (Tagged "view" (State (Cached v)) : r) (Cached v))
-> Sem (State (Cached v) : r) (Cached v)
-> Sem (Tagged "view" (State (Cached v)) : r) (Cached v)
forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Member (State (Cached v)) r =>
Sem r (Cached v)
forall s (r :: EffectRow). Member (State s) r => Sem r s
get @(Cached v)
            case Cached v
dirty of
              Cached v
Dirty -> do
                s
s <- Sem (Tagged "view" (State (Cached v)) : r) s
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
                v
v' <- Sem r v -> Sem (Tagged "view" (State (Cached v)) : r) v
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (Sem r v -> Sem (Tagged "view" (State (Cached v)) : r) v)
-> Sem r v -> Sem (Tagged "view" (State (Cached v)) : r) v
forall a b. (a -> b) -> a -> b
$ s -> Sem r v
f s
s
                forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e : r) a -> Sem (Tagged k2 e : r) a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e : r) a -> Sem (Tagged "view" e : r) a
tagged @"view" (Sem (State (Cached v) : r) ()
 -> Sem (Tagged "view" (State (Cached v)) : r) ())
-> Sem (State (Cached v) : r) ()
-> Sem (Tagged "view" (State (Cached v)) : r) ()
forall a b. (a -> b) -> a -> b
$ Cached v -> Sem (State (Cached v) : r) ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put (Cached v -> Sem (State (Cached v) : r) ())
-> Cached v -> Sem (State (Cached v) : r) ()
forall a b. (a -> b) -> a -> b
$ v -> Cached v
forall a. a -> Cached a
Cached v
v'
                v -> Sem (Tagged "view" (State (Cached v)) : r) v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v'
              Cached v
v -> v -> Sem (Tagged "view" (State (Cached v)) : r) v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v
      )


data Cached a = Cached a | Dirty
  deriving (Cached a -> Cached a -> Bool
(Cached a -> Cached a -> Bool)
-> (Cached a -> Cached a -> Bool) -> Eq (Cached a)
forall a. Eq a => Cached a -> Cached a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cached a -> Cached a -> Bool
$c/= :: forall a. Eq a => Cached a -> Cached a -> Bool
== :: Cached a -> Cached a -> Bool
$c== :: forall a. Eq a => Cached a -> Cached a -> Bool
Eq, Eq (Cached a)
Eq (Cached a)
-> (Cached a -> Cached a -> Ordering)
-> (Cached a -> Cached a -> Bool)
-> (Cached a -> Cached a -> Bool)
-> (Cached a -> Cached a -> Bool)
-> (Cached a -> Cached a -> Bool)
-> (Cached a -> Cached a -> Cached a)
-> (Cached a -> Cached a -> Cached a)
-> Ord (Cached a)
Cached a -> Cached a -> Bool
Cached a -> Cached a -> Ordering
Cached a -> Cached a -> Cached a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Cached a)
forall a. Ord a => Cached a -> Cached a -> Bool
forall a. Ord a => Cached a -> Cached a -> Ordering
forall a. Ord a => Cached a -> Cached a -> Cached a
min :: Cached a -> Cached a -> Cached a
$cmin :: forall a. Ord a => Cached a -> Cached a -> Cached a
max :: Cached a -> Cached a -> Cached a
$cmax :: forall a. Ord a => Cached a -> Cached a -> Cached a
>= :: Cached a -> Cached a -> Bool
$c>= :: forall a. Ord a => Cached a -> Cached a -> Bool
> :: Cached a -> Cached a -> Bool
$c> :: forall a. Ord a => Cached a -> Cached a -> Bool
<= :: Cached a -> Cached a -> Bool
$c<= :: forall a. Ord a => Cached a -> Cached a -> Bool
< :: Cached a -> Cached a -> Bool
$c< :: forall a. Ord a => Cached a -> Cached a -> Bool
compare :: Cached a -> Cached a -> Ordering
$ccompare :: forall a. Ord a => Cached a -> Cached a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Cached a)
Ord, Int -> Cached a -> ShowS
[Cached a] -> ShowS
Cached a -> String
(Int -> Cached a -> ShowS)
-> (Cached a -> String) -> ([Cached a] -> ShowS) -> Show (Cached a)
forall a. Show a => Int -> Cached a -> ShowS
forall a. Show a => [Cached a] -> ShowS
forall a. Show a => Cached a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cached a] -> ShowS
$cshowList :: forall a. Show a => [Cached a] -> ShowS
show :: Cached a -> String
$cshow :: forall a. Show a => Cached a -> String
showsPrec :: Int -> Cached a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Cached a -> ShowS
Show, a -> Cached b -> Cached a
(a -> b) -> Cached a -> Cached b
(forall a b. (a -> b) -> Cached a -> Cached b)
-> (forall a b. a -> Cached b -> Cached a) -> Functor Cached
forall a b. a -> Cached b -> Cached a
forall a b. (a -> b) -> Cached a -> Cached b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Cached b -> Cached a
$c<$ :: forall a b. a -> Cached b -> Cached a
fmap :: (a -> b) -> Cached a -> Cached b
$cfmap :: forall a b. (a -> b) -> Cached a -> Cached b
Functor)