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

-- |
-- This module contains basic examples advices.
--
-- __/BEWARE!/__ These are provided for illustrative purposes only, they
-- strive for simplicity and not robustness or efficiency.
module Dep.IOAdvice.Basic 
  ( -- * Basic advices
    returnMempty,
    printArgs,
  )
where

import Dep.IOAdvice
import Control.Monad.Dep
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
import Control.Monad.IO.Unlift
import Control.Exception
import qualified Data.Typeable as T
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.IORef

-- $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 Dep.IOAdvice
-- >>> import Dep.IOAdvice.Basic
-- >>> import Control.Monad
-- >>> 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 r. Monoid r => Advice ca r
returnMempty :: forall (ca :: * -> Constraint) r. Monoid r => Advice ca r
returnMempty =
  forall (ca :: * -> Constraint) r. (IO r -> IO r) -> Advice ca r
makeExecutionAdvice
    ( \IO r
action -> do
        r
_ <- IO r
action
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty :: r)
    )

-- | Given a 'Handle' and a prefix string, makes functions print their
-- arguments to the 'Handle'.
--
printArgs :: forall r . Handle -> String -> Advice Show r
printArgs :: forall r. Handle -> String -> Advice Show r
printArgs Handle
h String
prefix =
  forall (ca :: * -> Constraint) r.
(forall (as :: [*]). All ca as => NP I as -> IO (NP I as))
-> Advice ca r
makeArgsAdvice
    ( \NP I as
args -> do
        Handle -> String -> IO ()
hPutStr Handle
h forall a b. (a -> b) -> a -> b
$ String
prefix forall a. [a] -> [a] -> [a]
++ String
":"
        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_ (forall {k} (t :: k). Proxy t
Proxy @Show) (\(I a
a) -> Handle -> String -> IO ()
hPutStr Handle
h (String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a)) NP I as
args
        Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n"
        Handle -> IO ()
hFlush Handle
h
        forall (f :: * -> *) a. Applicative f => a -> f a
pure NP I as
args
    )