di-polysemy 0.1.3.1 → 0.1.4.0
raw patch · 3 files changed
+60/−20 lines, 3 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ DiPolysemy: runDiToIOFinal :: forall r level msg a. Members '[Final IO, Embed IO] r => (Log level Path msg -> IO ()) -> Sem (Di level Path msg : r) a -> Sem r a
+ DiPolysemy: runDiToStderrIOFinal :: Members '[Final IO, Embed IO] r => Sem (Di Level Path Message : r) a -> Sem r a
- DiPolysemy: flush :: forall level_a9Vu path_a9Vv msg_a9Vw r_aazm. MemberWithError (Di level_a9Vu path_a9Vv msg_a9Vw) r_aazm => Sem r_aazm ()
+ DiPolysemy: flush :: forall level_a9Zy path_a9Zz msg_a9ZA r_aaDq. MemberWithError (Di level_a9Zy path_a9Zz msg_a9ZA) r_aaDq => Sem r_aaDq ()
- DiPolysemy: local :: forall level_a9Vy path_a9Vz msg_a9VA r_aazn a_a9VC. MemberWithError (Di level_a9Vy path_a9Vz msg_a9VA) r_aazn => (Di level_a9Vy path_a9Vz msg_a9VA -> Di level_a9Vy path_a9Vz msg_a9VA) -> Sem r_aazn a_a9VC -> Sem r_aazn a_a9VC
+ DiPolysemy: local :: forall level_a9ZC path_a9ZD msg_a9ZE r_aaDr a_a9ZG. MemberWithError (Di level_a9ZC path_a9ZD msg_a9ZE) r_aaDr => (Di level_a9ZC path_a9ZD msg_a9ZE -> Di level_a9ZC path_a9ZD msg_a9ZE) -> Sem r_aaDr a_a9ZG -> Sem r_aaDr a_a9ZG
- DiPolysemy: log :: forall level_a9Vq path_a9Vs msg_a9Vr r_aazj. MemberWithError (Di level_a9Vq path_a9Vs msg_a9Vr) r_aazj => level_a9Vq -> msg_a9Vr -> Sem r_aazj ()
+ DiPolysemy: log :: forall level_a9Zu path_a9Zw msg_a9Zv r_aaDn. MemberWithError (Di level_a9Zu path_a9Zw msg_a9Zv) r_aaDn => level_a9Zu -> msg_a9Zv -> Sem r_aaDn ()
- DiPolysemy: reset :: forall level_a9VF path_a9VG msg_a9VH r_aazq a_a9VE. MemberWithError (Di level_a9VF path_a9VG msg_a9VH) r_aazq => Sem r_aazq a_a9VE -> Sem r_aazq a_a9VE
+ DiPolysemy: reset :: forall level_a9ZJ path_a9ZK msg_a9ZL r_aaDu a_a9ZI. MemberWithError (Di level_a9ZJ path_a9ZK msg_a9ZL) r_aaDu => Sem r_aaDu a_a9ZI -> Sem r_aaDu a_a9ZI
Files
- CHANGELOG.md +4/−0
- di-polysemy.cabal +2/−2
- src/DiPolysemy.hs +54/−18
CHANGELOG.md view
@@ -3,6 +3,10 @@ `di-polysemy` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.1.4.0++* `runDiToIOFinal` and `runDiToStderrIOFinal` have been added+ ## 0.1.3.0 * The 'Reset' action has been added
di-polysemy.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 28b2f36f02478805bfe9c6d2da769eb470c6bd9e31b6ad61b9f28c5b6ac5f7a6+-- hash: 7d5a66b6c7f2d80869176c92262777e8ff5e62c94a600d922c5ee4a2d4a75b77 name: di-polysemy-version: 0.1.3.1+version: 0.1.4.0 synopsis: DI logger wrapped for Polysemy description: Please see the README on GitHub at <https://github.com/nitros12/di-polysemy> category: Logging
src/DiPolysemy.hs view
@@ -2,6 +2,8 @@ ( Di(..) , runDiToIO , runDiToStderrIO+ , runDiToIOFinal+ , runDiToStderrIOFinal , log , flush , local@@ -38,6 +40,9 @@ 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 ()@@ -69,33 +74,64 @@ 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+ => Sem (Di level Df1.Path msg ': r) a+ -> Sem r a+interpretDi = interpretH $ \case+ Log level msg -> do+ (_, di) <- P.ask @(DiR level msg)+ (embed @IO $ DC.log di level msg) >>= pureT+ Flush -> do+ (_, di) <- P.ask @(DiR level 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+ runDiToIO :: forall r level msg a. Member (Embed IO) r => (DC.Log level Df1.Path msg -> IO ()) -> Sem (Di level Df1.Path msg ': r) a -> Sem r a-runDiToIO commit m = diToIO $ runDiIOInner commit (flip (P.runReader . dup) $ go (raiseUnder m))- where- go :: Member (Embed IO) r0- => Sem (Di level Df1.Path msg ': r0) a0- -> Sem (P.Reader (DiR level msg) ': r0) a0- go = reinterpretH $ \case- Log level msg -> do- (_, di) <- P.ask @(DiR level msg)- (embed @IO $ DC.log di level msg) >>= pureT- Flush -> do- (_, di) <- P.ask @(DiR level msg)- (embed @IO $ DC.flush di) >>= pureT- Local f m -> do- m' <- go <$> runT m- raise $ subsume $ P.local @(DiR level msg) (fmap f) m'- Reset m -> do- m' <- go <$> runT m- raise $ subsume $ P.local @(DiR level msg) (\(odi, _) -> (odi, odi)) m'+runDiToIO commit m = diToIO inner+ where inner :: Sem (DiIOInner ': r) a+ inner = runDiIOInner commit (raise . flip (P.runReader . dup) (interpretDi $ raiseUnder m))+ runDiToStderrIO :: Member (Embed IO) r => Sem (Di Df1.Level Df1.Path Df1.Message ': r) a -> Sem r a runDiToStderrIO m = do