di-polysemy (empty) → 0.1.0.0
raw patch · 6 files changed
+256/−0 lines, 6 filesdep +basedep +df1dep +di-core
Dependencies added: base, df1, di-core, di-df1, di-handle, polysemy, polysemy-plugin
Files
- CHANGELOG.md +11/−0
- LICENSE +29/−0
- README.md +4/−0
- cabal.project +10/−0
- di-polysemy.cabal +58/−0
- src/DiPolysemy.hs +144/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`di-polysemy` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/nitros12/di-polysemy/releases
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2019, Ben Simms+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+# di-polysemy++[di](https://hackage.haskell.org/package/di) adaptors for [polysemy](https://hackage.haskell.org/package/polysemy)+
+ cabal.project view
@@ -0,0 +1,10 @@+-- Generated by stackage-to-hackage++with-compiler: ghc-8.6.5++packages:+ ./+++allow-older: *+allow-newer: *
+ di-polysemy.cabal view
@@ -0,0 +1,58 @@+cabal-version: 1.18+name: di-polysemy+version: 0.1.0.0+license: MIT+license-file: LICENSE+copyright: 2020 Ben Simms+maintainer: ben@bensimms.moe+author: Ben Simms+tested-with: ghc ==8.6.5+homepage: https://github.com/nitros12/di-polysemy+bug-reports: https://github.com/nitros12/di-polysemy/issues+synopsis: DI logger wrapped for Polysemy+description:+ Please see the README on GitHub at <https://github.com/nitros12/di-polysemy>+category: Logging+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ cabal.project+extra-doc-files: README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/nitros12/di-polysemy++library+ exposed-modules:+ DiPolysemy+ hs-source-dirs: src+ other-modules:+ Paths_di_polysemy+ default-language: Haskell2010+ default-extensions: TemplateHaskell RecursiveDo CPP+ AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction+ AutoDeriveTypeable BangPatterns BinaryLiterals UndecidableInstances+ ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+ DoAndIfThenElse EmptyDataDecls ExistentialQuantification+ FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+ DerivingVia DerivingStrategies GeneralizedNewtypeDeriving+ StandaloneDeriving DeriveAnyClass InstanceSigs KindSignatures+ LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf+ NamedFieldPuns OverloadedStrings OverloadedLabels+ PartialTypeSignatures PatternGuards PolyKinds RankNTypes+ RecordWildCards ScopedTypeVariables TupleSections TypeFamilies+ TypeSynonymInstances ViewPatterns DuplicateRecordFields+ TypeOperators TypeApplications RoleAnnotations PatternSynonyms+ ghc-options: -fplugin=Polysemy.Plugin -Wall+ build-depends:+ base >=4.12 && <5,+ df1 >=0.3.2 && <0.4,+ di-core >=1.0.4 && <2,+ di-df1 >=1.2 && <2,+ di-handle >=1.0.1 && <2,+ polysemy >=1.3 && <2,+ polysemy-plugin ==0.2.*
+ src/DiPolysemy.hs view
@@ -0,0 +1,144 @@+module DiPolysemy+ ( Di(..)+ , runDiToIO+ , runDiToStderrIO+ , log+ , flush+ , push+ , attr_+ , attr+ , debug+ , info+ , notice+ , warning+ , error+ , alert+ , critical+ , emergency+ , debug_+ , info_+ , notice_+ , warning_+ , error_+ , alert_+ , critical_+ , emergency_ ) where++import Data.Functor++import qualified Df1 as D++import qualified Di.Core as DC+import qualified Di.Df1 as Df1+import qualified Di.Handle as DH++import Polysemy++import Prelude hiding ( error, log )++data Di level path msg m a where+ Log :: level -> msg -> Di level path msg m ()+ Flush :: Di level path msg m ()+ Push :: D.Segment -> m a -> Di level D.Path msg m a+ Attr_ :: D.Key -> D.Value -> m a -> Di level D.Path msg m a++makeSem ''Di++data DiIOInner m a where+ RunDiIOInner :: (DC.Log level D.Path msg -> IO ()) -> (DC.Di level D.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))++runDiToIO+ :: forall r level msg a.+ Member (Embed IO) r+ => (DC.Log level D.Path msg -> IO ())+ -> Sem (Di level D.Path msg ': r) a+ -> Sem r a+runDiToIO commit m = diToIO $ runDiIOInner commit (`go` raiseUnder m)+ where+ go :: Member (Embed IO) r0 => DC.Di level D.Path msg -> Sem (Di level D.Path msg ': r0) a0 -> Sem r0 a0+ go di m = (`interpretH` m) $ \case+ Log level msg -> do+ t <- embed $ DC.log di level msg+ pureT t+ Flush -> do+ t <- embed $ DC.flush di+ pureT t+ Push s m' -> do+ mm <- runT m'+ raise $ go (Df1.push s di) mm+ Attr_ k v m' -> do+ mm <- runT m'+ raise $ go (Df1.attr_ k v di) mm++runDiToStderrIO :: Member (Embed IO) r => Sem (Di D.Level D.Path D.Message ': r) a -> Sem r a+runDiToStderrIO m = do+ commit <- embed $ DH.stderr Df1.df1+ runDiToIO commit m++attr :: (D.ToValue value, Member (Di level D.Path msg) r) => D.Key -> value -> Sem r a -> Sem r a+attr k v = attr_ k (D.value v)++debug :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+debug = log D.Debug . D.message++info :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+info = log D.Info . D.message++notice :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+notice = log D.Notice . D.message++warning :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+warning = log D.Warning . D.message++error :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+error = log D.Error . D.message++alert :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+alert = log D.Alert . D.message++critical :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+critical = log D.Critical . D.message++emergency :: (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()+emergency = log D.Emergency . D.message++debug_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+debug_ = log D.Debug++info_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+info_ = log D.Info++notice_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+notice_ = log D.Notice++warning_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+warning_ = log D.Warning++error_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+error_ = log D.Error++alert_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+alert_ = log D.Alert++critical_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+critical_ = log D.Critical++emergency_ :: Member (Di D.Level path D.Message) r => D.Message -> Sem r ()+emergency_ = log D.Emergency