{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}


-- |

-- This module contains examples of simple advices.

--

-- __/BEWARE!/__ These are provided for illustrative purposes only, they

-- strive for simplicity and not robustness or efficiency.

module Control.Monad.Dep.Advice.Basic
  ( -- * Basic advices

    returnMempty,
    printArgs,
    AnyEq (..),
    doCachingBadly,
    doAsyncBadly
  )
where

import Control.Monad.Dep
import Control.Monad.Dep.Advice
import Data.Proxy
import Data.SOP
import Data.SOP (hctraverse_)
import Data.SOP.NP
import Data.Type.Equality
import System.IO
import Type.Reflection
import Control.Concurrent

-- | Makes functions discard their result and always return 'mempty'.

--

-- Because it doesn't touch the arguments or require some effect from the

-- environment, this 'Advice' is polymorphic on @ca@ and @cem@.

returnMempty :: forall ca cem. Advice ca cem Monoid
returnMempty :: Advice ca cem Monoid
returnMempty =
  (forall (e :: (* -> *) -> *) (m :: * -> *) r.
 (cem e m, Monad m, Monoid r) =>
 DepT e m r -> DepT e m r)
-> Advice ca cem Monoid
forall (ca :: * -> Constraint)
       (cem :: ((* -> *) -> *) -> (* -> *) -> Constraint)
       (cr :: * -> Constraint).
(forall (e :: (* -> *) -> *) (m :: * -> *) r.
 (cem e m, Monad m, cr r) =>
 DepT e m r -> DepT e m r)
-> Advice ca cem cr
makeExecutionAdvice
    ( \DepT e m r
action -> do
        r
_ <- DepT e m r
action
        r -> DepT e m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty
    )

-- | Given a 'Handle' and a prefix string, makes functions print their

-- arguments to the 'Handle'.

--

-- This advice uses 'MonadConstraint' to lift the 'MonadIO' constraint that

-- applies only to the monad.

--

-- Because it doesn't touch the return value of the advised function, this

-- 'Advice' is polymorphic on @cr@.

printArgs :: forall cr. Handle -> String -> Advice Show (MonadConstraint MonadIO) cr
printArgs :: Handle -> String -> Advice Show (MonadConstraint MonadIO) cr
printArgs Handle
h String
prefix =
  (forall (as :: [*]) (e :: (* -> *) -> *) (m :: * -> *).
 (All Show as, MonadConstraint MonadIO e m, Monad m) =>
 NP I as -> DepT e m (NP I as))
-> Advice Show (MonadConstraint MonadIO) cr
forall (ca :: * -> Constraint)
       (cem :: ((* -> *) -> *) -> (* -> *) -> Constraint)
       (cr :: * -> Constraint).
(forall (as :: [*]) (e :: (* -> *) -> *) (m :: * -> *).
 (All ca as, cem e m, Monad m) =>
 NP I as -> DepT e m (NP I as))
-> Advice ca cem cr
makeArgsAdvice
    ( \NP I as
args -> do
        IO () -> DepT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DepT e m ()) -> IO () -> DepT e m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
        Proxy Show
-> (forall a. Show a => I a -> DepT e m ())
-> NP I as
-> DepT e m ()
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
       (f :: k -> *).
(HTraverse_ h, AllN h c xs, Applicative g) =>
proxy c -> (forall (a :: k). c a => f a -> g ()) -> h f xs -> g ()
hctraverse_ (Proxy Show
forall k (t :: k). Proxy t
Proxy @Show) (\(I a) -> IO () -> DepT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStr Handle
h (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a))) NP I as
args
        IO () -> DepT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DepT e m ()) -> IO () -> DepT e m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n"
        IO () -> DepT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DepT e m ()) -> IO () -> DepT e m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h
        NP I as -> DepT e m (NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NP I as
args
    )

-- | A helper datatype for universal equality comparisons of existentialized values, used by 'doCachingBadly'.

--

-- For a more complete elaboration of this idea, see the the \"exinst\" package.

data AnyEq where
  AnyEq :: forall a. (Typeable a, Eq a) => a -> AnyEq

instance Eq AnyEq where
  AnyEq a
any1 == :: AnyEq -> AnyEq -> Bool
== AnyEq a
any2 =
    case TypeRep a -> TypeRep a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf a
any1) (a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf a
any2) of
      Maybe (a :~: a)
Nothing -> Bool
False
      Just a :~: a
Refl -> a
any1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
any2

-- | 

-- Given the means for looking up and storing values in the underlying monad

-- @m@, makes functions (inefficiently) cache their results.

--

-- Notice the equality constraints on the 'Advice'. This means that the monad

-- @m@ and the result type @r@ are known and fixed before building the advice.

-- Once built, the 'Advice' won't be polymorphic over them.

--

-- The implementation of this function makes use of the existential type

-- parameter @u@ of 'makeAdvice', because the phase that processes the function

-- arguments needs to communicate the calculated `AnyEq` cache key to the phase

-- that processes the function result.

--

-- A better implementation of this advice would likely use an @AnyHashable@

-- helper datatype for the keys.

doCachingBadly :: forall m r. (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) (MonadConstraint (MustBe m)) (MustBe r)
doCachingBadly :: (AnyEq -> m (Maybe r))
-> (AnyEq -> r -> m ())
-> Advice (And Eq Typeable) (MonadConstraint (MustBe m)) (MustBe r)
doCachingBadly AnyEq -> m (Maybe r)
cacheLookup AnyEq -> r -> m ()
cachePut =
  (forall (as :: [*]) (e :: (* -> *) -> *) (m :: * -> *).
 (All (And Eq Typeable) as, MonadConstraint (MustBe m) e m,
  Monad m) =>
 NP I as -> DepT e m (AnyEq, NP I as))
-> (forall (e :: (* -> *) -> *) (m :: * -> *) r.
    (MonadConstraint (MustBe m) e m, Monad m, MustBe r r) =>
    AnyEq -> DepT e m r -> DepT e m r)
-> Advice (And Eq Typeable) (MonadConstraint (MustBe m)) (MustBe r)
forall u (ca :: * -> Constraint)
       (cem :: ((* -> *) -> *) -> (* -> *) -> Constraint)
       (cr :: * -> Constraint).
(forall (as :: [*]) (e :: (* -> *) -> *) (m :: * -> *).
 (All ca as, cem e m, Monad m) =>
 NP I as -> DepT e m (u, NP I as))
-> (forall (e :: (* -> *) -> *) (m :: * -> *) r.
    (cem e m, Monad m, cr r) =>
    u -> DepT e m r -> DepT e m r)
-> Advice ca cem cr
makeAdvice @AnyEq
    ( \NP I as
args ->
        let key :: AnyEq
key = [AnyEq] -> AnyEq
forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq ([AnyEq] -> AnyEq) -> [AnyEq] -> AnyEq
forall a b. (a -> b) -> a -> b
$ Proxy (And Eq Typeable)
-> (forall a. And Eq Typeable a => I a -> [AnyEq])
-> NP I as
-> [AnyEq]
forall k (c :: k -> Constraint) (xs :: [k]) m
       (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(All c xs, Monoid m) =>
proxy c -> (forall (a :: k). c a => f a -> m) -> NP f xs -> m
cfoldMap_NP (Proxy (And Eq Typeable)
forall k (t :: k). Proxy t
Proxy @(And Eq Typeable)) (\(I a) -> [a -> AnyEq
forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq a
a]) (NP I as -> [AnyEq]) -> NP I as -> [AnyEq]
forall a b. (a -> b) -> a -> b
$ NP I as
args
         in (AnyEq, NP I as) -> DepT e m (AnyEq, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyEq
key, NP I as
args)
    )
    ( \AnyEq
key DepT e m r
action -> do
        Maybe r
mr <- m (Maybe r) -> DepT e m (Maybe r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe r) -> DepT e m (Maybe r))
-> m (Maybe r) -> DepT e m (Maybe r)
forall a b. (a -> b) -> a -> b
$ AnyEq -> m (Maybe r)
cacheLookup AnyEq
key
        case Maybe r
mr of
          Maybe r
Nothing -> do
            r
r <- DepT e m r
action
            m () -> DepT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> DepT e m ()) -> m () -> DepT e m ()
forall a b. (a -> b) -> a -> b
$ AnyEq -> r -> m ()
cachePut AnyEq
key r
r
r
            r -> DepT e m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
          Just r
r ->
            r -> DepT e m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    )

-- | Makes functions that return `()` launch asynchronously.

--

-- A better implementation of this advice would likely use the \"async\"

-- package instead of bare `forkIO`. 

--

-- And the @MustBe IO@ constraint could be relaxed to @MonadUnliftIO@.

doAsyncBadly :: Advice ca (MonadConstraint (MustBe IO)) (MustBe ())
doAsyncBadly :: Advice ca (MonadConstraint (MustBe IO)) (MustBe ())
doAsyncBadly = (forall (e :: (* -> *) -> *) (m :: * -> *) r.
 (MonadConstraint (MustBe IO) e m, Monad m, MustBe () r) =>
 DepT e m r -> DepT e m r)
-> Advice ca (MonadConstraint (MustBe IO)) (MustBe ())
forall (ca :: * -> Constraint)
       (cem :: ((* -> *) -> *) -> (* -> *) -> Constraint)
       (cr :: * -> Constraint).
(forall (e :: (* -> *) -> *) (m :: * -> *) r.
 (cem e m, Monad m, cr r) =>
 DepT e m r -> DepT e m r)
-> Advice ca cem cr
makeExecutionAdvice (\DepT e m r
action -> do
        e (DepT e m)
e <- DepT e m (e (DepT e m))
forall r (m :: * -> *). MonadReader r m => m r
ask 
        ThreadId
_ <- IO ThreadId -> DepT e m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> DepT e m ThreadId)
-> IO ThreadId -> DepT e m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ DepT e m r -> e (DepT e m) -> m r
forall (env :: (* -> *) -> *) (m :: * -> *) r.
DepT env m r -> env (DepT env m) -> m r
runDepT DepT e m r
action e (DepT e m)
e
        () -> DepT e m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    )