diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,15 @@ `di-polysemy` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.2.0.0 + +* `runDiToStderrIO`, `runDiToIOFinal`, `runDiToStderrIOFinal` and the `Reset` + action have been removed. +* The `Fetch` action has been added. +* `runDiToIOReader`, and `runDiNoop` has been added. +* `runDiToIO` now needs a `Di` value to be passed to it, the library now doesn't + create the Di value. + ## 0.1.4.0 * `runDiToIOFinal` and `runDiToStderrIOFinal` have been added diff --git a/di-polysemy.cabal b/di-polysemy.cabal --- a/di-polysemy.cabal +++ b/di-polysemy.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 7d5a66b6c7f2d80869176c92262777e8ff5e62c94a600d922c5ee4a2d4a75b77 +-- hash: a0bb51a5a8806c6d7ff483420aa6c02be35a5f140268a5366b07fecb070832d0 name: di-polysemy -version: 0.1.4.0 +version: 0.2.0.0 synopsis: DI logger wrapped for Polysemy description: Please see the README on GitHub at category: Logging diff --git a/src/DiPolysemy.hs b/src/DiPolysemy.hs --- a/src/DiPolysemy.hs +++ b/src/DiPolysemy.hs @@ -1,13 +1,12 @@ module DiPolysemy ( Di(..) + , runDiToIOReader , runDiToIO - , runDiToStderrIO - , runDiToIOFinal - , runDiToStderrIOFinal + , runDiNoop , log , flush , local - , reset + , fetch , push , attr_ , attr @@ -34,109 +33,50 @@ import qualified Di.Core as DC import qualified Di.Df1 as Df1 -import qualified Di.Handle as DH import Polysemy import qualified Polysemy.Reader as P import Prelude hiding ( error, log ) -import Control.Concurrent (takeMVar, MVar, putMVar, newEmptyMVar) -import Polysemy.Async (asyncToIOFinal, async) -import Polysemy.Resource (resourceToIOFinal, bracket) data Di level path msg m a where Log :: level -> msg -> Di level path msg m () Flush :: Di level path msg m () Local :: (DC.Di level path msg -> DC.Di level path msg) -> m a -> Di level path msg m a - Reset :: m a -> Di level path msg m a + -- | Fetch the current Di value, 'Maybe' to allow for no-op implementations + Fetch :: Di level path msg m (Maybe (DC.Di level path msg)) makeSem ''Di -data DiIOInner m a where - RunDiIOInner :: (DC.Log level Df1.Path msg -> IO ()) -> (DC.Di level Df1.Path msg -> m a) -> DiIOInner m a - -makeSem ''DiIOInner - -diToIO :: forall r a. Member (Embed IO) r => Sem (DiIOInner ': r) a -> Sem r a -diToIO = interpretH - (\case RunDiIOInner commit a -> do - istate <- getInitialStateT - ma <- bindT a - - withLowerToIO $ \lower finish -> do - let done :: Sem (DiIOInner ': r) x -> IO x - done = lower . raise . diToIO - - DC.new commit (\di -> do - res <- done (ma $ istate $> di) - finish - pure res)) - -type DiR level msg = (DC.Di level Df1.Path msg, DC.Di level Df1.Path msg) - -interpretDi :: forall r a level msg. Members '[Embed IO, P.Reader (DiR level msg)] r +runDiToIOReader :: forall r a level msg. Members '[Embed IO, P.Reader (DC.Di level Df1.Path msg)] r => Sem (Di level Df1.Path msg ': r) a -> Sem r a -interpretDi = interpretH $ \case +runDiToIOReader = interpretH $ \case Log level msg -> do - (_, di) <- P.ask @(DiR level msg) + di <- P.ask @(DC.Di level Df1.Path msg) (embed @IO $ DC.log di level msg) >>= pureT Flush -> do - (_, di) <- P.ask @(DiR level msg) + di <- P.ask @(DC.Di level Df1.Path msg) (embed @IO $ DC.flush di) >>= pureT Local f m -> do - m' <- interpretDi <$> runT m - raise $ P.local @(DiR level msg) (fmap f) m' - Reset m -> do - m' <- interpretDi <$> runT m - raise $ P.local @(DiR level msg) (\(odi, _) -> (odi, odi)) m' - -dup :: a -> (a, a) -dup a = (a, a) - -runDiToIOFinal - :: forall r level msg a. - Members '[Final IO, Embed IO] r - => (DC.Log level Df1.Path msg -> IO ()) - -> Sem (Di level Df1.Path msg ': r) a - -> Sem r a -runDiToIOFinal commit m = do - diIn <- embedFinal newEmptyMVar - diOut <- embedFinal newEmptyMVar - void . asyncToIOFinal . async . embedFinal $ DC.new commit $ outer diIn diOut - inner diIn diOut - where - outer :: MVar (DC.Di level Df1.Path msg) -> MVar (DC.Di level Df1.Path msg) -> (DC.Di level Df1.Path msg) -> IO () - outer aIn aOut a = do - putMVar aIn a - void $ takeMVar aOut - - inner :: MVar (DC.Di level Df1.Path msg) -> MVar (DC.Di level Df1.Path msg) -> Sem r a - inner diIn diOut = resourceToIOFinal $ bracket - (embedFinal $ takeMVar diIn) - (embedFinal . putMVar diOut) - (\di -> raise . P.runReader (di, di) $ interpretDi (raiseUnder $ m)) - -runDiToStderrIOFinal :: Members '[Final IO, Embed IO] r => Sem (Di Df1.Level Df1.Path Df1.Message ': r) a -> Sem r a -runDiToStderrIOFinal m = do - commit <- embedFinal @IO $ DH.stderr Df1.df1 - runDiToIOFinal commit m + m' <- runDiToIOReader <$> runT m + raise $ P.local @(DC.Di level Df1.Path msg) f m' + Fetch -> do + di <- Just <$> P.ask @(DC.Di level Df1.Path msg) + pureT di -runDiToIO - :: forall r level msg a. - Member (Embed IO) r - => (DC.Log level Df1.Path msg -> IO ()) +runDiToIO :: forall r level msg a. Member (Embed IO) r + => DC.Di level Df1.Path msg -> Sem (Di level Df1.Path msg ': r) a -> Sem r a -runDiToIO commit m = diToIO inner - where inner :: Sem (DiIOInner ': r) a - inner = runDiIOInner commit (raise . flip (P.runReader . dup) (interpretDi $ raiseUnder m)) - +runDiToIO di = P.runReader di . runDiToIOReader . raiseUnder -runDiToStderrIO :: Member (Embed IO) r => Sem (Di Df1.Level Df1.Path Df1.Message ': r) a -> Sem r a -runDiToStderrIO m = do - commit <- embed @IO $ DH.stderr Df1.df1 - runDiToIO commit m +runDiNoop :: forall r level msg a. Sem (Di level Df1.Path msg ': r) a -> Sem r a +runDiNoop = interpretH \case + Log _level _msg -> pureT () + Flush -> pureT () + Local _f m -> runDiNoop <$> runT m >>= raise + Fetch -> pureT Nothing push :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Segment -> Sem r a -> Sem r a push s = local @level @Df1.Path @msg (Df1.push s)