{-# 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,
    doLocally,
    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

-- $setup

--

-- >>> :set -XTypeApplications

-- >>> :set -XStandaloneKindSignatures

-- >>> :set -XMultiParamTypeClasses

-- >>> :set -XFunctionalDependencies

-- >>> :set -XRankNTypes

-- >>> :set -XTypeOperators

-- >>> :set -XConstraintKinds

-- >>> :set -XNamedFieldPuns

-- >>> :set -XFlexibleContexts

-- >>> :set -XFlexibleInstances

-- >>> :set -XAllowAmbiguousTypes

-- >>> :set -XBlockArguments

-- >>> import Control.Monad

-- >>> import Control.Monad.Dep

-- >>> import Control.Monad.Dep.Advice

-- >>> import Control.Monad.Dep.Advice.Basic (printArgs,returnMempty)

-- >>> import Data.Kind

-- >>> import Data.SOP

-- >>> import Data.SOP.NP

-- >>> import Data.Monoid

-- >>> import System.IO

-- >>> import Data.IORef




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

--

returnMempty :: forall ca e_ m r. (Monad m, Monoid r) => Advice ca e_ m r
returnMempty :: Advice ca e_ m r
returnMempty =
  (DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
Applicative m =>
(DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
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 :: r)
    )

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

-- arguments to the 'Handle'.

--

printArgs :: forall e_ m r. MonadIO m => Handle -> String -> Advice Show e_ m r
printArgs :: Handle -> String -> Advice Show e_ m r
printArgs Handle
h String
prefix =
  (forall (as :: [*]). All Show as => NP I as -> DepT e_ m (NP I as))
-> Advice Show e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
Monad m =>
(forall (as :: [*]). All ca as => NP I as -> DepT e_ m (NP I as))
-> Advice ca e_ m r
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
    )

-- | Use 'local' on the final 'DepT' action of a function.

--

-- Allows tweaking the environment that will be seen by the function and all of

-- its sub-calls into dependencies. 

--

-- Perhaps this is __not__ what you want; often, it's better to tweak

-- the environment for the current function only. For those cases,

-- 'Control.Monad.Dep.Advice.deceive' might be a better fit. 

--

-- >>> :{

--  type HasLogger :: Type -> (Type -> Type) -> Constraint

--  class HasLogger em m | em -> m where

--    logger :: em -> String -> m ()

--  type Env :: (Type -> Type) -> Type

--  data Env m = Env

--    { _logger1 :: String -> m (),

--      _logger2 :: String -> m (),

--      _controllerA :: Int -> m (),

--      _controllerB :: Int -> m ()

--    }

--  instance HasLogger (Env m) m where

--    logger = _logger1

--  envIO :: Env (DepT Env IO)

--  envIO = Env 

--    {

--      _logger1 = 

--          \_ -> liftIO $ putStrLn "logger1 ran",

--      _logger2 = 

--          \_ -> liftIO $ putStrLn "logger2 ran",

--      _controllerA = 

--          \_ -> do e <- ask; logger e "foo",

--      _controllerB = 

--          advise @Top 

--          (doLocally \e@Env{_logger2} -> e {_logger1 = _logger2}) 

--          \_ -> do e <- ask; logger e "foo" 

--    }

-- :}

--

--  >>> runFromEnv (pure envIO) _controllerA 0

--  logger1 ran

--

--  >>> runFromEnv (pure envIO) _controllerB 0

--  logger2 ran

--

doLocally :: forall ca e_ m r. Monad m => (forall n. e_ n -> e_ n) -> Advice ca e_ m r 
doLocally :: (forall (n :: * -> *). e_ n -> e_ n) -> Advice ca e_ m r
doLocally forall (n :: * -> *). e_ n -> e_ n
transform = (DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
Applicative m =>
(DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
makeExecutionAdvice ((e_ (DepT e_ m) -> e_ (DepT e_ m)) -> DepT e_ m r -> DepT e_ m r
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e_ (DepT e_ m) -> e_ (DepT e_ m)
forall (n :: * -> *). e_ n -> e_ n
transform)  


-- | 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 @r@ values in the underlying

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

--

-- The monad @m@ and the result type @r@ must be known before building the

-- advice. So, once built, this '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 e_ m r. Monad m => (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) e_ m r
doCachingBadly :: (AnyEq -> m (Maybe r))
-> (AnyEq -> r -> m ()) -> Advice (And Eq Typeable) e_ m r
doCachingBadly AnyEq -> m (Maybe r)
cacheLookup AnyEq -> r -> m ()
cachePut =
  (forall (as :: [*]).
 All (And Eq Typeable) as =>
 NP I as -> DepT e_ m (AnyEq, NP I as))
-> (AnyEq -> DepT e_ m r -> DepT e_ m r)
-> Advice (And Eq Typeable) e_ m r
forall u (ca :: * -> Constraint) (e_ :: (* -> *) -> *)
       (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (u, NP I as))
-> (u -> DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
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 -> 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`. 

--

-- The @IO@ monad could be generalized to @MonadUnliftIO@.

doAsyncBadly :: forall ca e_ . Advice ca e_ IO ()
doAsyncBadly :: Advice ca e_ IO ()
doAsyncBadly = (DepT e_ IO () -> DepT e_ IO ()) -> Advice ca e_ IO ()
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
Applicative m =>
(DepT e_ m r -> DepT e_ m r) -> Advice ca e_ m r
makeExecutionAdvice (\DepT e_ IO ()
action -> do
        e_ (DepT e_ IO)
e <- DepT e_ IO (e_ (DepT e_ IO))
forall r (m :: * -> *). MonadReader r m => m r
ask 
        ThreadId
_ <- IO ThreadId -> DepT e_ IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> DepT e_ IO ThreadId)
-> IO ThreadId -> DepT e_ IO 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_ IO () -> e_ (DepT e_ IO) -> IO ()
forall (e_ :: (* -> *) -> *) (m :: * -> *) r.
DepT e_ m r -> e_ (DepT e_ m) -> m r
runDepT DepT e_ IO ()
action e_ (DepT e_ IO)
e
        () -> DepT e_ IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    )