{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | A version of 'GraphulaT' that logs the generated graph
module Graphula.Logged
  ( GraphulaLoggedT
  , runGraphulaLoggedT
  , runGraphulaLoggedWithFileT
  , runGraphulaLoggedUsingT
  ) where

import Prelude

import Control.Monad.IO.Unlift
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Foldable (traverse_)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Sequence (Seq, empty, (|>))
import Data.Text (Text, pack)
import qualified Data.Text.IO as T
import Graphula.Class
import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)
import System.IO (Handle, IOMode(..), hClose, openFile)
import System.IO.Temp (openTempFile)
import Test.HUnit.Lang
  (FailureReason(..), HUnitFailure(..), formatFailureReason)
import UnliftIO.Exception (bracket, catch, throwIO)

newtype GraphulaLoggedT m a = GraphulaLoggedT
  { forall (m :: * -> *) a.
GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
runGraphulaLoggedT' :: ReaderT (IORef (Seq Text)) m a
  }
  deriving newtype
    ( forall a b. a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
forall a b. (a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
fmap :: forall a b. (a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
Functor
    , forall a. a -> GraphulaLoggedT m a
forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
forall a b.
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
forall a b c.
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (GraphulaLoggedT m)
forall (m :: * -> *) a. Applicative m => a -> GraphulaLoggedT m a
forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
<* :: forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
*> :: forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
liftA2 :: forall a b c.
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
<*> :: forall a b.
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
pure :: forall a. a -> GraphulaLoggedT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GraphulaLoggedT m a
Applicative
    , forall a. a -> GraphulaLoggedT m a
forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
forall a b.
GraphulaLoggedT m a
-> (a -> GraphulaLoggedT m b) -> GraphulaLoggedT m b
forall {m :: * -> *}. Monad m => Applicative (GraphulaLoggedT m)
forall (m :: * -> *) a. Monad m => a -> GraphulaLoggedT m a
forall (m :: * -> *) a b.
Monad m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
forall (m :: * -> *) a b.
Monad m =>
GraphulaLoggedT m a
-> (a -> GraphulaLoggedT m b) -> GraphulaLoggedT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> GraphulaLoggedT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GraphulaLoggedT m a
>> :: forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
>>= :: forall a b.
GraphulaLoggedT m a
-> (a -> GraphulaLoggedT m b) -> GraphulaLoggedT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GraphulaLoggedT m a
-> (a -> GraphulaLoggedT m b) -> GraphulaLoggedT m b
Monad
    , forall a. IO a -> GraphulaLoggedT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (GraphulaLoggedT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GraphulaLoggedT m a
liftIO :: forall a. IO a -> GraphulaLoggedT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GraphulaLoggedT m a
MonadIO
    , MonadReader (IORef (Seq Text))
    )

instance MonadUnliftIO m => MonadUnliftIO (GraphulaLoggedT m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: forall b.
((forall a. GraphulaLoggedT m a -> IO a) -> IO b)
-> GraphulaLoggedT m b
withRunInIO (forall a. GraphulaLoggedT m a -> IO a) -> IO b
inner =
    forall (m :: * -> *) a.
ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a
GraphulaLoggedT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT (IORef (Seq Text)) m a -> IO a
run -> (forall a. GraphulaLoggedT m a -> IO a) -> IO b
inner forall a b. (a -> b) -> a -> b
$ forall a. ReaderT (IORef (Seq Text)) m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
runGraphulaLoggedT'

instance MonadTrans GraphulaLoggedT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> GraphulaLoggedT m a
lift = forall (m :: * -> *) a.
ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a
GraphulaLoggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLoggedT m) where
  type Logging (GraphulaLoggedT m) = Show
  askGen :: GraphulaLoggedT m (IORef QCGen)
askGen = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadGraphulaBackend m => m (IORef QCGen)
askGen
  logNode :: forall a.
Logging (GraphulaLoggedT m) a =>
a -> GraphulaLoggedT m ()
logNode a
n = do
    IORef (Seq Text)
graphLog <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq Text)
graphLog (forall a. Seq a -> a -> Seq a
|> String -> Text
pack (forall a. Show a => a -> String
show a
n))

instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where
  insert :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaLoggedT m), GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> GraphulaLoggedT m (Maybe (Entity a))
insert Maybe (Key a)
mKey = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
 PersistEntity a, Monad m, GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> m (Maybe (Entity a))
insert Maybe (Key a)
mKey
  remove :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaLoggedT m)) =>
Key a -> GraphulaLoggedT m ()
remove = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
 PersistEntity a, Monad m) =>
Key a -> m ()
remove

-- | Run the graph while logging to a temporary file
runGraphulaLoggedT :: MonadUnliftIO m => GraphulaLoggedT m a -> m a
runGraphulaLoggedT :: forall (m :: * -> *) a.
MonadUnliftIO m =>
GraphulaLoggedT m a -> m a
runGraphulaLoggedT = forall (m :: * -> *) a.
MonadUnliftIO m =>
(IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
runGraphulaLoggedUsingT forall (m :: * -> *) a.
MonadIO m =>
IORef (Seq Text) -> HUnitFailure -> m a
logFailTemp

-- | 'runGraphulaLoggedT', but to the specified file
runGraphulaLoggedWithFileT
  :: MonadUnliftIO m => FilePath -> GraphulaLoggedT m a -> m a
runGraphulaLoggedWithFileT :: forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> GraphulaLoggedT m a -> m a
runGraphulaLoggedWithFileT = forall (m :: * -> *) a.
MonadUnliftIO m =>
(IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
runGraphulaLoggedUsingT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadIO m =>
String -> IORef (Seq Text) -> HUnitFailure -> m a
logFailFile

-- | 'runGraphulaLoggedT', but using the custom action to accumulate
runGraphulaLoggedUsingT
  :: MonadUnliftIO m
  => (IORef (Seq Text) -> HUnitFailure -> m a)
  -> GraphulaLoggedT m a
  -> m a
runGraphulaLoggedUsingT :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
runGraphulaLoggedUsingT IORef (Seq Text) -> HUnitFailure -> m a
logFail GraphulaLoggedT m a
action = do
  IORef (Seq Text)
graphLog <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Seq a
empty
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a.
GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
runGraphulaLoggedT' GraphulaLoggedT m a
action) IORef (Seq Text)
graphLog forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IORef (Seq Text) -> HUnitFailure -> m a
logFail IORef (Seq Text)
graphLog

logFailUsing
  :: MonadIO m
  => IO (FilePath, Handle)
  -> IORef (Seq Text)
  -> HUnitFailure
  -> m a
logFailUsing :: forall (m :: * -> *) a.
MonadIO m =>
IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
logFailUsing IO (String, Handle)
f IORef (Seq Text)
graphLog HUnitFailure
hunitfailure =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitLogged HUnitFailure
hunitfailure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
IORef (Seq Text) -> IO (String, Handle) -> m String
logGraphToHandle IORef (Seq Text)
graphLog IO (String, Handle)
f

logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a
logFailFile :: forall (m :: * -> *) a.
MonadIO m =>
String -> IORef (Seq Text) -> HUnitFailure -> m a
logFailFile String
path = forall (m :: * -> *) a.
MonadIO m =>
IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
logFailUsing ((String
path, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode)

logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a
logFailTemp :: forall (m :: * -> *) a.
MonadIO m =>
IORef (Seq Text) -> HUnitFailure -> m a
logFailTemp = forall (m :: * -> *) a.
MonadIO m =>
IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
logFailUsing forall a b. (a -> b) -> a -> b
$ do
  String
tmp <- (forall a. [a] -> [a] -> [a]
++ String
"/graphula") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getTemporaryDirectory
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
tmp
  String -> String -> IO (String, Handle)
openTempFile String
tmp String
"fail-.graphula"

logGraphToHandle
  :: (MonadIO m) => IORef (Seq Text) -> IO (FilePath, Handle) -> m FilePath
logGraphToHandle :: forall (m :: * -> *).
MonadIO m =>
IORef (Seq Text) -> IO (String, Handle) -> m String
logGraphToHandle IORef (Seq Text)
graphLog IO (String, Handle)
openHandle = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
  IO (String, Handle)
openHandle
  (Handle -> IO ()
hClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
  (\(String
path, Handle
handle) -> do
    Seq Text
nodes <- forall a. IORef a -> IO a
readIORef IORef (Seq Text)
graphLog
    String
path forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
handle) Seq Text
nodes
  )

rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a
rethrowHUnitLogged :: forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitLogged String
path =
  forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith (String
"Graph dumped in temp file: " forall a. [a] -> [a] -> [a]
++ String
path)

rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith :: forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith String
message (HUnitFailure Maybe SrcLoc
l FailureReason
r) =
  forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FailureReason
Reason forall a b. (a -> b) -> a -> b
$ String
message forall a. [a] -> [a] -> [a]
++ String
"\n\n" forall a. [a] -> [a] -> [a]
++ FailureReason -> String
formatFailureReason FailureReason
r