{-# 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 -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b)
-> (forall a b. a -> GraphulaLoggedT m b -> GraphulaLoggedT m a)
-> Functor (GraphulaLoggedT m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
fmap :: forall a b. (a -> b) -> GraphulaLoggedT m a -> GraphulaLoggedT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
<$ :: forall a b. a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
Functor
    , Functor (GraphulaLoggedT m)
Functor (GraphulaLoggedT m) =>
(forall a. a -> GraphulaLoggedT m a)
-> (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 a b.
    GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b)
-> (forall a b.
    GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a)
-> Applicative (GraphulaLoggedT m)
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
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GraphulaLoggedT m a
pure :: forall a. a -> GraphulaLoggedT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
<*> :: forall a b.
GraphulaLoggedT m (a -> b)
-> GraphulaLoggedT m a -> GraphulaLoggedT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> GraphulaLoggedT m a
-> GraphulaLoggedT m b
-> GraphulaLoggedT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
*> :: 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 a
<* :: forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m a
Applicative
    , Applicative (GraphulaLoggedT m)
Applicative (GraphulaLoggedT m) =>
(forall a b.
 GraphulaLoggedT m a
 -> (a -> GraphulaLoggedT m b) -> GraphulaLoggedT m b)
-> (forall a b.
    GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b)
-> (forall a. a -> GraphulaLoggedT m a)
-> Monad (GraphulaLoggedT m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GraphulaLoggedT m a
-> (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 -> GraphulaLoggedT m b -> GraphulaLoggedT m b
>> :: forall a b.
GraphulaLoggedT m a -> GraphulaLoggedT m b -> GraphulaLoggedT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GraphulaLoggedT m a
return :: forall a. a -> GraphulaLoggedT m a
Monad
    , Monad (GraphulaLoggedT m)
Monad (GraphulaLoggedT m) =>
(forall a. IO a -> GraphulaLoggedT m a)
-> MonadIO (GraphulaLoggedT m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GraphulaLoggedT m a
liftIO :: forall a. 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 =
    ReaderT (IORef (Seq Text)) m b -> GraphulaLoggedT m b
forall (m :: * -> *) a.
ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a
GraphulaLoggedT (ReaderT (IORef (Seq Text)) m b -> GraphulaLoggedT m b)
-> ReaderT (IORef (Seq Text)) m b -> GraphulaLoggedT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT (IORef (Seq Text)) m a -> IO a) -> IO b)
-> ReaderT (IORef (Seq Text)) m b
forall b.
((forall a. ReaderT (IORef (Seq Text)) m a -> IO a) -> IO b)
-> ReaderT (IORef (Seq Text)) m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT (IORef (Seq Text)) m a -> IO a) -> IO b)
 -> ReaderT (IORef (Seq Text)) m b)
-> ((forall a. ReaderT (IORef (Seq Text)) m a -> IO a) -> IO b)
-> ReaderT (IORef (Seq Text)) m b
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. GraphulaLoggedT m a -> IO a) -> IO b)
-> (forall a. GraphulaLoggedT m a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ ReaderT (IORef (Seq Text)) m a -> IO a
forall a. ReaderT (IORef (Seq Text)) m a -> IO a
run (ReaderT (IORef (Seq Text)) m a -> IO a)
-> (GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a)
-> GraphulaLoggedT m a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
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 = ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a
forall (m :: * -> *) a.
ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a
GraphulaLoggedT (ReaderT (IORef (Seq Text)) m a -> GraphulaLoggedT m a)
-> (m a -> ReaderT (IORef (Seq Text)) m a)
-> m a
-> GraphulaLoggedT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (IORef (Seq Text)) m a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef (Seq Text)) m a
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 = m (IORef QCGen) -> GraphulaLoggedT m (IORef QCGen)
forall (m :: * -> *) a. Monad m => m a -> GraphulaLoggedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (IORef QCGen)
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 <- GraphulaLoggedT m (IORef (Seq Text))
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> GraphulaLoggedT m ()
forall a. IO a -> GraphulaLoggedT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GraphulaLoggedT m ()) -> IO () -> GraphulaLoggedT m ()
forall a b. (a -> b) -> a -> b
$ IORef (Seq Text) -> (Seq Text -> Seq Text) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Seq Text)
graphLog (Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
|> String -> Text
pack (a -> String
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 = m (Maybe (Entity a)) -> GraphulaLoggedT m (Maybe (Entity a))
forall (m :: * -> *) a. Monad m => m a -> GraphulaLoggedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Entity a)) -> GraphulaLoggedT m (Maybe (Entity a)))
-> (a -> m (Maybe (Entity a)))
-> a
-> GraphulaLoggedT m (Maybe (Entity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Key a) -> a -> m (Maybe (Entity a))
forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m,
 GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> m (Maybe (Entity a))
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
  insertKeyed :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaLoggedT m)) =>
Key a -> a -> GraphulaLoggedT m (Maybe (Entity a))
insertKeyed Key a
key = m (Maybe (Entity a)) -> GraphulaLoggedT m (Maybe (Entity a))
forall (m :: * -> *) a. Monad m => m a -> GraphulaLoggedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Entity a)) -> GraphulaLoggedT m (Maybe (Entity a)))
-> (a -> m (Maybe (Entity a)))
-> a
-> GraphulaLoggedT m (Maybe (Entity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key a -> a -> m (Maybe (Entity a))
forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) =>
Key a -> a -> m (Maybe (Entity a))
forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
 PersistEntity a, Monad m) =>
Key a -> a -> m (Maybe (Entity a))
insertKeyed Key a
key
  remove :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaLoggedT m)) =>
Key a -> GraphulaLoggedT m ()
remove = m () -> GraphulaLoggedT m ()
forall (m :: * -> *) a. Monad m => m a -> GraphulaLoggedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> GraphulaLoggedT m ())
-> (Key a -> m ()) -> Key a -> GraphulaLoggedT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key a -> m ()
forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) =>
Key a -> m ()
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 = (IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
runGraphulaLoggedUsingT IORef (Seq Text) -> HUnitFailure -> m a
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 = (IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IORef (Seq Text) -> HUnitFailure -> m a)
-> GraphulaLoggedT m a -> m a
runGraphulaLoggedUsingT ((IORef (Seq Text) -> HUnitFailure -> m a)
 -> GraphulaLoggedT m a -> m a)
-> (String -> IORef (Seq Text) -> HUnitFailure -> m a)
-> String
-> GraphulaLoggedT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IORef (Seq Text) -> HUnitFailure -> m a
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 <- IO (IORef (Seq Text)) -> m (IORef (Seq Text))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Seq Text)) -> m (IORef (Seq Text)))
-> IO (IORef (Seq Text)) -> m (IORef (Seq Text))
forall a b. (a -> b) -> a -> b
$ Seq Text -> IO (IORef (Seq Text))
forall a. a -> IO (IORef a)
newIORef Seq Text
forall a. Seq a
empty
  ReaderT (IORef (Seq Text)) m a -> IORef (Seq Text) -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
forall (m :: * -> *) a.
GraphulaLoggedT m a -> ReaderT (IORef (Seq Text)) m a
runGraphulaLoggedT' GraphulaLoggedT m a
action) IORef (Seq Text)
graphLog m a -> (HUnitFailure -> m a) -> m a
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 =
  (String -> HUnitFailure -> m a) -> HUnitFailure -> String -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> HUnitFailure -> m a
forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitLogged HUnitFailure
hunitfailure (String -> m a) -> m String -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Seq Text) -> IO (String, Handle) -> m String
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 = IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
forall (m :: * -> *) a.
MonadIO m =>
IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
logFailUsing ((String
path,) (Handle -> (String, Handle)) -> IO Handle -> IO (String, Handle)
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 = IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
forall (m :: * -> *) a.
MonadIO m =>
IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
logFailUsing (IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a)
-> IO (String, Handle) -> IORef (Seq Text) -> HUnitFailure -> m a
forall a b. (a -> b) -> a -> b
$ do
  String
tmp <- (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/graphula") (String -> String) -> IO String -> IO String
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 =
  IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$
    IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO String)
-> IO String
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 (Handle -> IO ())
-> ((String, Handle) -> Handle) -> (String, Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Handle) -> Handle
forall a b. (a, b) -> b
snd)
      ( \(String
path, Handle
handle) -> do
          Seq Text
nodes <- IORef (Seq Text) -> IO (Seq Text)
forall a. IORef a -> IO a
readIORef IORef (Seq Text)
graphLog
          String
path String -> IO () -> IO String
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> IO ()) -> Seq Text -> IO ()
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 =
  String -> HUnitFailure -> m a
forall (m :: * -> *) a. MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith (String
"Graph dumped in temp file: " String -> String -> String
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) =
  HUnitFailure -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (HUnitFailure -> m a) -> (String -> HUnitFailure) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
l (FailureReason -> HUnitFailure)
-> (String -> FailureReason) -> String -> HUnitFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FailureReason
Reason (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FailureReason -> String
formatFailureReason FailureReason
r