{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Module : Test.Method.Monitor.Internal
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
module Test.Method.Monitor.Internal where

import Data.Typeable (typeOf)
import RIO
  ( IORef,
    MonadIO,
    SomeException,
    SomeRef,
    Typeable,
    modifySomeRef,
    newIORef,
    newSomeRef,
    readIORef,
    writeIORef,
  )

-- | 'Tick' represents call identifier
newtype Tick = Tick {Tick -> Int
unTick :: Int}
  deriving (Tick -> Tick -> Bool
(Tick -> Tick -> Bool) -> (Tick -> Tick -> Bool) -> Eq Tick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tick -> Tick -> Bool
$c/= :: Tick -> Tick -> Bool
== :: Tick -> Tick -> Bool
$c== :: Tick -> Tick -> Bool
Eq, Eq Tick
Eq Tick
-> (Tick -> Tick -> Ordering)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> Ord Tick
Tick -> Tick -> Bool
Tick -> Tick -> Ordering
Tick -> Tick -> Tick
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
min :: Tick -> Tick -> Tick
$cmin :: Tick -> Tick -> Tick
max :: Tick -> Tick -> Tick
$cmax :: Tick -> Tick -> Tick
>= :: Tick -> Tick -> Bool
$c>= :: Tick -> Tick -> Bool
> :: Tick -> Tick -> Bool
$c> :: Tick -> Tick -> Bool
<= :: Tick -> Tick -> Bool
$c<= :: Tick -> Tick -> Bool
< :: Tick -> Tick -> Bool
$c< :: Tick -> Tick -> Bool
compare :: Tick -> Tick -> Ordering
$ccompare :: Tick -> Tick -> Ordering
$cp1Ord :: Eq Tick
Ord, Int -> Tick -> ShowS
[Tick] -> ShowS
Tick -> String
(Int -> Tick -> ShowS)
-> (Tick -> String) -> ([Tick] -> ShowS) -> Show Tick
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tick] -> ShowS
$cshowList :: [Tick] -> ShowS
show :: Tick -> String
$cshow :: Tick -> String
showsPrec :: Int -> Tick -> ShowS
$cshowsPrec :: Int -> Tick -> ShowS
Show, Int -> Tick
Tick -> Int
Tick -> [Tick]
Tick -> Tick
Tick -> Tick -> [Tick]
Tick -> Tick -> Tick -> [Tick]
(Tick -> Tick)
-> (Tick -> Tick)
-> (Int -> Tick)
-> (Tick -> Int)
-> (Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> Tick -> [Tick])
-> Enum Tick
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
$cenumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
enumFromTo :: Tick -> Tick -> [Tick]
$cenumFromTo :: Tick -> Tick -> [Tick]
enumFromThen :: Tick -> Tick -> [Tick]
$cenumFromThen :: Tick -> Tick -> [Tick]
enumFrom :: Tick -> [Tick]
$cenumFrom :: Tick -> [Tick]
fromEnum :: Tick -> Int
$cfromEnum :: Tick -> Int
toEnum :: Int -> Tick
$ctoEnum :: Int -> Tick
pred :: Tick -> Tick
$cpred :: Tick -> Tick
succ :: Tick -> Tick
$csucc :: Tick -> Tick
Enum)

-- | @'Event' args ret@ is a function call event
data Event args ret
  = Enter {Event args ret -> Tick
eventTick :: !Tick, Event args ret -> args
eventArgs :: !args}
  | Leave
      { eventTick :: !Tick,
        Event args ret -> Tick
eventEnterTick :: !Tick,
        Event args ret -> Either (EqUptoShow SomeException) ret
eventRet :: !(Either (EqUptoShow SomeException) ret)
      }
  deriving (Event args ret -> Event args ret -> Bool
(Event args ret -> Event args ret -> Bool)
-> (Event args ret -> Event args ret -> Bool)
-> Eq (Event args ret)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall args ret.
(Eq args, Eq ret) =>
Event args ret -> Event args ret -> Bool
/= :: Event args ret -> Event args ret -> Bool
$c/= :: forall args ret.
(Eq args, Eq ret) =>
Event args ret -> Event args ret -> Bool
== :: Event args ret -> Event args ret -> Bool
$c== :: forall args ret.
(Eq args, Eq ret) =>
Event args ret -> Event args ret -> Bool
Eq, Eq (Event args ret)
Eq (Event args ret)
-> (Event args ret -> Event args ret -> Ordering)
-> (Event args ret -> Event args ret -> Bool)
-> (Event args ret -> Event args ret -> Bool)
-> (Event args ret -> Event args ret -> Bool)
-> (Event args ret -> Event args ret -> Bool)
-> (Event args ret -> Event args ret -> Event args ret)
-> (Event args ret -> Event args ret -> Event args ret)
-> Ord (Event args ret)
Event args ret -> Event args ret -> Bool
Event args ret -> Event args ret -> Ordering
Event args ret -> Event args ret -> Event args ret
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 args ret. (Ord args, Ord ret) => Eq (Event args ret)
forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Bool
forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Ordering
forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Event args ret
min :: Event args ret -> Event args ret -> Event args ret
$cmin :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Event args ret
max :: Event args ret -> Event args ret -> Event args ret
$cmax :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Event args ret
>= :: Event args ret -> Event args ret -> Bool
$c>= :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Bool
> :: Event args ret -> Event args ret -> Bool
$c> :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Bool
<= :: Event args ret -> Event args ret -> Bool
$c<= :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Bool
< :: Event args ret -> Event args ret -> Bool
$c< :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Bool
compare :: Event args ret -> Event args ret -> Ordering
$ccompare :: forall args ret.
(Ord args, Ord ret) =>
Event args ret -> Event args ret -> Ordering
$cp1Ord :: forall args ret. (Ord args, Ord ret) => Eq (Event args ret)
Ord, Int -> Event args ret -> ShowS
[Event args ret] -> ShowS
Event args ret -> String
(Int -> Event args ret -> ShowS)
-> (Event args ret -> String)
-> ([Event args ret] -> ShowS)
-> Show (Event args ret)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall args ret.
(Show args, Show ret) =>
Int -> Event args ret -> ShowS
forall args ret. (Show args, Show ret) => [Event args ret] -> ShowS
forall args ret. (Show args, Show ret) => Event args ret -> String
showList :: [Event args ret] -> ShowS
$cshowList :: forall args ret. (Show args, Show ret) => [Event args ret] -> ShowS
show :: Event args ret -> String
$cshow :: forall args ret. (Show args, Show ret) => Event args ret -> String
showsPrec :: Int -> Event args ret -> ShowS
$cshowsPrec :: forall args ret.
(Show args, Show ret) =>
Int -> Event args ret -> ShowS
Show)

type Clock = IORef Tick

-- | newtype to implement show instance which shows its type.
newtype ShowType a = ShowType a
  deriving (ShowType a -> ShowType a -> Bool
(ShowType a -> ShowType a -> Bool)
-> (ShowType a -> ShowType a -> Bool) -> Eq (ShowType a)
forall a. Eq a => ShowType a -> ShowType a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowType a -> ShowType a -> Bool
$c/= :: forall a. Eq a => ShowType a -> ShowType a -> Bool
== :: ShowType a -> ShowType a -> Bool
$c== :: forall a. Eq a => ShowType a -> ShowType a -> Bool
Eq, Eq (ShowType a)
Eq (ShowType a)
-> (ShowType a -> ShowType a -> Ordering)
-> (ShowType a -> ShowType a -> Bool)
-> (ShowType a -> ShowType a -> Bool)
-> (ShowType a -> ShowType a -> Bool)
-> (ShowType a -> ShowType a -> Bool)
-> (ShowType a -> ShowType a -> ShowType a)
-> (ShowType a -> ShowType a -> ShowType a)
-> Ord (ShowType a)
ShowType a -> ShowType a -> Bool
ShowType a -> ShowType a -> Ordering
ShowType a -> ShowType a -> ShowType 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 (ShowType a)
forall a. Ord a => ShowType a -> ShowType a -> Bool
forall a. Ord a => ShowType a -> ShowType a -> Ordering
forall a. Ord a => ShowType a -> ShowType a -> ShowType a
min :: ShowType a -> ShowType a -> ShowType a
$cmin :: forall a. Ord a => ShowType a -> ShowType a -> ShowType a
max :: ShowType a -> ShowType a -> ShowType a
$cmax :: forall a. Ord a => ShowType a -> ShowType a -> ShowType a
>= :: ShowType a -> ShowType a -> Bool
$c>= :: forall a. Ord a => ShowType a -> ShowType a -> Bool
> :: ShowType a -> ShowType a -> Bool
$c> :: forall a. Ord a => ShowType a -> ShowType a -> Bool
<= :: ShowType a -> ShowType a -> Bool
$c<= :: forall a. Ord a => ShowType a -> ShowType a -> Bool
< :: ShowType a -> ShowType a -> Bool
$c< :: forall a. Ord a => ShowType a -> ShowType a -> Bool
compare :: ShowType a -> ShowType a -> Ordering
$ccompare :: forall a. Ord a => ShowType a -> ShowType a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (ShowType a)
Ord)

instance Typeable a => Show (ShowType a) where
  show :: ShowType a -> String
show (ShowType a
a) = TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)

-- | newtype to compare values via 'show'
newtype EqUptoShow a = EqUptoShow a

instance Show a => Show (EqUptoShow a) where
  show :: EqUptoShow a -> String
show (EqUptoShow a
a) = a -> String
forall a. Show a => a -> String
show a
a

instance Show a => Eq (EqUptoShow a) where
  EqUptoShow a
a == :: EqUptoShow a -> EqUptoShow a -> Bool
== EqUptoShow a
b = EqUptoShow a -> String
forall a. Show a => a -> String
show EqUptoShow a
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== EqUptoShow a -> String
forall a. Show a => a -> String
show EqUptoShow a
b

instance Show a => Ord (EqUptoShow a) where
  compare :: EqUptoShow a -> EqUptoShow a -> Ordering
compare EqUptoShow a
a EqUptoShow a
b = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (EqUptoShow a -> String
forall a. Show a => a -> String
show EqUptoShow a
a) (EqUptoShow a -> String
forall a. Show a => a -> String
show EqUptoShow a
b)

-- | @Monitor arg ret@ is an event monitor of methods,
-- which logs method calls.
data Monitor args ret = Monitor
  { Monitor args ret -> SomeRef [Event args ret]
monitorTrace :: !(SomeRef [Event args ret]),
    Monitor args ret -> Clock
monitorClock :: !Clock
  }

-- | Generate new instance of 'Monitor'
newMonitor :: IO (Monitor args ret)
newMonitor :: IO (Monitor args ret)
newMonitor = SomeRef [Event args ret] -> Clock -> Monitor args ret
forall args ret.
SomeRef [Event args ret] -> Clock -> Monitor args ret
Monitor (SomeRef [Event args ret] -> Clock -> Monitor args ret)
-> IO (SomeRef [Event args ret]) -> IO (Clock -> Monitor args ret)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event args ret] -> IO (SomeRef [Event args ret])
forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef [] IO (Clock -> Monitor args ret) -> IO Clock -> IO (Monitor args ret)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tick -> IO Clock
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int -> Tick
Tick Int
0)

-- | Increment the clock and return the current tick.
{-# INLINE tick #-}
tick :: MonadIO m => Monitor args ret -> m Tick
tick :: Monitor args ret -> m Tick
tick Monitor {monitorClock :: forall args ret. Monitor args ret -> Clock
monitorClock = Clock
clock} = do
  Tick
t <- Clock -> m Tick
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef Clock
clock
  Clock -> Tick -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef Clock
clock (Tick -> m ()) -> Tick -> m ()
forall a b. (a -> b) -> a -> b
$! Tick -> Tick
forall a. Enum a => a -> a
succ Tick
t
  Tick -> m Tick
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tick
t

-- | logs an event
{-# INLINE logEvent #-}
logEvent :: MonadIO m => Monitor args ret -> Event args ret -> m ()
logEvent :: Monitor args ret -> Event args ret -> m ()
logEvent Monitor {monitorTrace :: forall args ret. Monitor args ret -> SomeRef [Event args ret]
monitorTrace = SomeRef [Event args ret]
tr} Event args ret
event = SomeRef [Event args ret]
-> ([Event args ret] -> [Event args ret]) -> m ()
forall (m :: * -> *) a. MonadIO m => SomeRef a -> (a -> a) -> m ()
modifySomeRef SomeRef [Event args ret]
tr (Event args ret
event Event args ret -> [Event args ret] -> [Event args ret]
forall a. a -> [a] -> [a]
:)