{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Skeletest.Internal.Hooks.HookDef (
  Hook (..),
  HookDef (..),
  HookPriority (..),
  runHook,

  -- * Hook DSL
  runEarly,
  runLate,
  mkHook,
  mkHook_,
  mkPreHook,
  mkPreHook_,
  mkPostHook,
  mkPostHook_,
) where

import Control.Monad ((>=>))
import Data.List (sortOn)

-- | The implementation of a Skeletest hook in 'Skeletest.Plugin.Hooks'.
--
-- A hook of type @Hook ctx inp out@ means:
--
--   * The hook takes a value of type @ctx@ with extra read-only information
--     that may be relevant for the hook.
--   * The hook takes an action of type @inp -> IO out@ and returns a
--     potentially modified action of the same type.
--
-- @ctx@/@inp@ should generally be accessed with @OverloadedRecordDot@ or record
-- destructuring, to minimize breaking changes when adding fields to them.
newtype Hook ctx inp out = Hook [HookDef ctx inp out]
  deriving newtype (Semigroup (Hook ctx inp out)
Hook ctx inp out
Semigroup (Hook ctx inp out) =>
Hook ctx inp out
-> (Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out)
-> ([Hook ctx inp out] -> Hook ctx inp out)
-> Monoid (Hook ctx inp out)
[Hook ctx inp out] -> Hook ctx inp out
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall ctx inp out. Semigroup (Hook ctx inp out)
forall ctx inp out. Hook ctx inp out
forall ctx inp out. [Hook ctx inp out] -> Hook ctx inp out
forall ctx inp out.
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
$cmempty :: forall ctx inp out. Hook ctx inp out
mempty :: Hook ctx inp out
$cmappend :: forall ctx inp out.
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
mappend :: Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
$cmconcat :: forall ctx inp out. [Hook ctx inp out] -> Hook ctx inp out
mconcat :: [Hook ctx inp out] -> Hook ctx inp out
Monoid, NonEmpty (Hook ctx inp out) -> Hook ctx inp out
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
(Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out)
-> (NonEmpty (Hook ctx inp out) -> Hook ctx inp out)
-> (forall b.
    Integral b =>
    b -> Hook ctx inp out -> Hook ctx inp out)
-> Semigroup (Hook ctx inp out)
forall b. Integral b => b -> Hook ctx inp out -> Hook ctx inp out
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall ctx inp out. NonEmpty (Hook ctx inp out) -> Hook ctx inp out
forall ctx inp out.
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
forall ctx inp out b.
Integral b =>
b -> Hook ctx inp out -> Hook ctx inp out
$c<> :: forall ctx inp out.
Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
<> :: Hook ctx inp out -> Hook ctx inp out -> Hook ctx inp out
$csconcat :: forall ctx inp out. NonEmpty (Hook ctx inp out) -> Hook ctx inp out
sconcat :: NonEmpty (Hook ctx inp out) -> Hook ctx inp out
$cstimes :: forall ctx inp out b.
Integral b =>
b -> Hook ctx inp out -> Hook ctx inp out
stimes :: forall b. Integral b => b -> Hook ctx inp out -> Hook ctx inp out
Semigroup)

data HookDef ctx inp out = HookDef
  { forall ctx inp out. HookDef ctx inp out -> HookPriority
priority :: HookPriority
  , forall ctx inp out.
HookDef ctx inp out -> ctx -> (inp -> IO out) -> inp -> IO out
impl :: ctx -> (inp -> IO out) -> (inp -> IO out)
  }

data HookPriority
  = NoPriority
  | EarlyPriority
  | LatePriority

defaultHookDef :: HookDef ctx inp out
defaultHookDef :: forall ctx inp out. HookDef ctx inp out
defaultHookDef =
  HookDef
    { priority :: HookPriority
priority = HookPriority
NoPriority
    , impl :: ctx -> (inp -> IO out) -> inp -> IO out
impl = \ctx
_ inp -> IO out
run -> inp -> IO out
run
    }

runHook :: Hook ctx inp out -> ctx -> inp -> (inp -> IO out) -> IO out
runHook :: forall ctx inp out.
Hook ctx inp out -> ctx -> inp -> (inp -> IO out) -> IO out
runHook (Hook [HookDef ctx inp out]
hookDefs) ctx
ctx inp
inp inp -> IO out
run = (HookDef ctx inp out -> (inp -> IO out) -> inp -> IO out)
-> (inp -> IO out) -> [HookDef ctx inp out] -> inp -> IO out
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HookDef ctx inp out -> (inp -> IO out) -> inp -> IO out
forall {r} {t} {t}.
HasField "impl" r (ctx -> t -> t) =>
r -> t -> t
go inp -> IO out
run ([HookDef ctx inp out] -> [HookDef ctx inp out]
orderHookDefs [HookDef ctx inp out]
hookDefs) inp
inp
 where
  orderHookDefs :: [HookDef ctx inp out] -> [HookDef ctx inp out]
orderHookDefs = (HookDef ctx inp out -> Int)
-> [HookDef ctx inp out] -> [HookDef ctx inp out]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((HookDef ctx inp out -> Int)
 -> [HookDef ctx inp out] -> [HookDef ctx inp out])
-> (HookDef ctx inp out -> Int)
-> [HookDef ctx inp out]
-> [HookDef ctx inp out]
forall a b. (a -> b) -> a -> b
$ \HookDef ctx inp out
def ->
    case HookDef ctx inp out
def.priority of
      HookPriority
NoPriority -> Int
0 :: Int
      HookPriority
EarlyPriority -> -Int
1
      HookPriority
LatePriority -> Int
1
  go :: r -> t -> t
go r
hookDef t
acc = r
hookDef.impl ctx
ctx t
acc

{----- DSL -----}

-- | Run the given hook earlier if possible.
runEarly :: Hook ctx inp out -> Hook ctx inp out
runEarly :: forall ctx inp out. Hook ctx inp out -> Hook ctx inp out
runEarly (Hook [HookDef ctx inp out]
hookDefs) = [HookDef ctx inp out] -> Hook ctx inp out
forall ctx inp out. [HookDef ctx inp out] -> Hook ctx inp out
Hook ((HookDef ctx inp out -> HookDef ctx inp out)
-> [HookDef ctx inp out] -> [HookDef ctx inp out]
forall a b. (a -> b) -> [a] -> [b]
map (\HookDef ctx inp out
def -> HookDef ctx inp out
def{priority = EarlyPriority}) [HookDef ctx inp out]
hookDefs)

-- | Run the given hook later if possible.
runLate :: Hook ctx inp out -> Hook ctx inp out
runLate :: forall ctx inp out. Hook ctx inp out -> Hook ctx inp out
runLate (Hook [HookDef ctx inp out]
hookDefs) = [HookDef ctx inp out] -> Hook ctx inp out
forall ctx inp out. [HookDef ctx inp out] -> Hook ctx inp out
Hook ((HookDef ctx inp out -> HookDef ctx inp out)
-> [HookDef ctx inp out] -> [HookDef ctx inp out]
forall a b. (a -> b) -> [a] -> [b]
map (\HookDef ctx inp out
def -> HookDef ctx inp out
def{priority = LatePriority}) [HookDef ctx inp out]
hookDefs)

-- | Create a hook.
--
-- === Example
-- @
-- hooks :: Hooks
-- hooks =
--   defaultHooks
--     { runSpecs = runEarly . mkHook $ \ctx run -> pre >=> run >=> post
--     }
--   where
--     pre inp = do
--       inp' <- doStuff inp
--       pure inp'
--     post out = do
--       out' <- doMoreStuff out
--       pure out'
-- @
mkHook :: (ctx -> (inp -> IO out) -> (inp -> IO out)) -> Hook ctx inp out
mkHook :: forall ctx inp out.
(ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
mkHook ctx -> (inp -> IO out) -> inp -> IO out
f = [HookDef ctx inp out] -> Hook ctx inp out
forall ctx inp out. [HookDef ctx inp out] -> Hook ctx inp out
Hook [HookDef Any Any Any
forall ctx inp out. HookDef ctx inp out
defaultHookDef{impl = f}]

-- | Like 'mkHook', except for read-only hooks that don't need to modify
-- anything.
mkHook_ ::
  (ctx -> inp -> IO ()) ->
  (ctx -> inp -> out -> IO ()) ->
  Hook ctx inp out
mkHook_ :: forall ctx inp out.
(ctx -> inp -> IO ())
-> (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
mkHook_ ctx -> inp -> IO ()
pre ctx -> inp -> out -> IO ()
post = (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall ctx inp out.
(ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
mkHook ((ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out)
-> (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall a b. (a -> b) -> a -> b
$ \ctx
ctx inp -> IO out
run inp
inp -> do
  ctx -> inp -> IO ()
pre ctx
ctx inp
inp
  out
out <- inp -> IO out
run inp
inp
  ctx -> inp -> out -> IO ()
post ctx
ctx inp
inp out
out
  out -> IO out
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure out
out

-- | Like 'mkHook', except only supports modifying the input.
mkPreHook :: (ctx -> inp -> IO inp) -> Hook ctx inp out
mkPreHook :: forall ctx inp out. (ctx -> inp -> IO inp) -> Hook ctx inp out
mkPreHook ctx -> inp -> IO inp
pre = (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall ctx inp out.
(ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
mkHook ((ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out)
-> (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall a b. (a -> b) -> a -> b
$ \ctx
ctx inp -> IO out
run -> ctx -> inp -> IO inp
pre ctx
ctx (inp -> IO inp) -> (inp -> IO out) -> inp -> IO out
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> inp -> IO out
run

-- | Like 'mkHook_', except with only a before action.
mkPreHook_ :: (ctx -> inp -> IO ()) -> Hook ctx inp out
mkPreHook_ :: forall ctx inp out. (ctx -> inp -> IO ()) -> Hook ctx inp out
mkPreHook_ ctx -> inp -> IO ()
pre = (ctx -> inp -> IO ())
-> (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
forall ctx inp out.
(ctx -> inp -> IO ())
-> (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
mkHook_ ctx -> inp -> IO ()
pre (\ctx
_ inp
_ out
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Like 'mkHook', except only supports modifying the output.
mkPostHook :: (ctx -> inp -> out -> IO out) -> Hook ctx inp out
mkPostHook :: forall ctx inp out.
(ctx -> inp -> out -> IO out) -> Hook ctx inp out
mkPostHook ctx -> inp -> out -> IO out
post = (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall ctx inp out.
(ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
mkHook ((ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out)
-> (ctx -> (inp -> IO out) -> inp -> IO out) -> Hook ctx inp out
forall a b. (a -> b) -> a -> b
$ \ctx
ctx inp -> IO out
run inp
inp -> inp -> IO out
run inp
inp IO out -> (out -> IO out) -> IO out
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ctx -> inp -> out -> IO out
post ctx
ctx inp
inp

-- | Like 'mkHook_', except with only an after action.
mkPostHook_ :: (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
mkPostHook_ :: forall ctx inp out.
(ctx -> inp -> out -> IO ()) -> Hook ctx inp out
mkPostHook_ ctx -> inp -> out -> IO ()
post = (ctx -> inp -> IO ())
-> (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
forall ctx inp out.
(ctx -> inp -> IO ())
-> (ctx -> inp -> out -> IO ()) -> Hook ctx inp out
mkHook_ (\ctx
_ inp
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ctx -> inp -> out -> IO ()
post