monad-classes-logging (empty) → 0.1.0.0

raw patch · 6 files changed

+244/−0 lines, 6 filesdep +basedep +ghc-primdep +logging-effectsetup-changed

Dependencies added: base, ghc-prim, logging-effect, monad-classes, monad-classes-logging, tasty, tasty-hunit, transformers

Files

LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
monad-classes-logging.cabal +55/−0
src/Control/Monad/Classes/Log.hs +115/−0
test/Spec.hs +39/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Author name here nor the names of other+      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+OWNER 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,3 @@+# monad-classes-logging++add description of monad-classes-logging here

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ monad-classes-logging.cabal view

@@ -0,0 +1,55 @@+name:                monad-classes-logging+version:             0.1.0.0+synopsis:            monad-classes based typeclass for Ollie's logging-effect LoggingT+description:         monad-classes based typeclass for Ollie's logging-effect LoggingT+homepage:            https://github.com/edwardgeorge/monad-classes-logging#readme+license:             BSD3+license-file:        LICENSE+author:              Edward George+maintainer:          edwardgeorge@gmail.com+copyright:           2017 Edward George+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++flag feuerbach+  description:         Use feuerbach version of monad-classes+  default:             False+  manual:              True++library+  hs-source-dirs:      src+  ghc-options:         -Wall+  exposed-modules:     Control.Monad.Classes.Log+  build-depends:       base >= 4.7 && < 5+                     , ghc-prim >= 0.5+                     , logging-effect >= 1.2+                     , transformers >= 0.5+  if flag(feuerbach)+     cpp-options:      -DUSE_FEUERBACH+     build-depends:    monad-classes >= 0.2+  else+     build-depends:    monad-classes >= 0.3+  default-language:    Haskell2010++test-suite monad-classes-logging-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , logging-effect >= 1.2+                     , tasty >= 0.11+                     , tasty-hunit >= 0.9+                     , transformers >= 0.5+                     , monad-classes-logging+  if flag(feuerbach)+     cpp-options:      -DUSE_FEUERBACH+     build-depends:    monad-classes >= 0.2+  else+     build-depends:    monad-classes >= 0.3+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/edwardgeorge/monad-classes-logging

+ src/Control/Monad/Classes/Log.hs view

@@ -0,0 +1,115 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts,+             FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Control.Monad.Classes.Log where+import Control.Monad.Classes+import Control.Monad.Log hiding (MonadLog(..),+                                 logMessage,+                                 mapLogMessage,+                                 mapLogMessageM,+                                 logDebug,+                                 logInfo,+                                 logNotice,+                                 logWarning,+                                 logError,+                                 logCritical,+                                 logAlert,+                                 logEmergency)+import qualified Control.Monad.Log as Log+import Control.Monad.Trans.Class (MonadTrans(..))+import GHC.Prim (proxy#, Proxy#)++data EffLog (w :: *)++type instance CanDo (LoggingT msg m) eff = LoggingCanDo msg eff+type instance CanDo (PureLoggingT msg m) eff = LoggingCanDo msg eff+type instance CanDo (DiscardLoggingT msg m) eff = LoggingCanDo msg eff++type family LoggingCanDo msg eff where+  LoggingCanDo msg (EffLog msg) = 'True+  LoggingCanDo msg eff          = 'False++#ifdef USE_FEUERBACH+class Monad m => MonadLogN (k :: Nat) message m where+#else+class Monad m => MonadLogN (k :: Peano) message m where+#endif+  logMessageFreeN :: Proxy# k -> (forall n. Monoid n => (message -> n) -> n) -> m ()++type MonadLog msg m = MonadLogN (Find (EffLog msg) m) msg m++instance Monad m => MonadLogN 'Zero msg (LoggingT msg m) where+  logMessageFreeN _ = Log.logMessageFree+  {-# INLINABLE logMessageFreeN #-}++instance (Monad m, Monoid msg) => MonadLogN 'Zero msg (PureLoggingT msg m) where+  logMessageFreeN _ = Log.logMessageFree+  {-# INLINABLE logMessageFreeN #-}++instance Monad m => MonadLogN 'Zero msg (DiscardLoggingT msg m) where+  logMessageFreeN _ = Log.logMessageFree+  {-# INLINABLE logMessageFreeN #-}++#ifdef USE_FEUERBACH+instance (MonadTrans t, MonadLogN k msg m, Monad (t m)) => MonadLogN ('Suc k) msg (t m) where+#else+instance (MonadTrans t, MonadLogN k msg m, Monad (t m)) => MonadLogN ('Succ k) msg (t m) where+#endif+  logMessageFreeN _ f = lift $ logMessageFreeN (proxy# :: Proxy# k) f+  {-# INLINABLE logMessageFreeN #-}++logMessageFree :: forall msg m. MonadLog msg m => (forall n. Monoid n => (msg -> n) -> n) -> m ()+logMessageFree = logMessageFreeN (proxy# :: Proxy# (Find (EffLog msg) m))+{-# INLINABLE logMessageFree #-}++logMessage :: MonadLog msg m => msg -> m ()+logMessage m = logMessageFree (\inject -> inject m)+{-# INLINABLE logMessage #-}++mapLogMessage :: MonadLog msg' m => (msg -> msg') -> LoggingT msg m a -> m a+mapLogMessage f m = runLoggingT m (logMessage . f)+{-# INLINABLE mapLogMessage #-}++mapLogMessageM :: MonadLog msg' m => (msg -> m msg') -> LoggingT msg m a -> m a+mapLogMessageM f m = runLoggingT m ((>>= logMessage) . f)+{-# INLINABLE mapLogMessageM #-}++logDebug :: MonadLog (WithSeverity a) m => a -> m ()+logDebug = logMessage . WithSeverity Debug+{-# INLINEABLE logDebug #-}++logInfo :: MonadLog (WithSeverity a) m => a -> m ()+logInfo      = logMessage . WithSeverity Informational+{-# INLINEABLE logInfo #-}++logNotice :: MonadLog (WithSeverity a) m => a -> m ()+logNotice    = logMessage . WithSeverity Notice+{-# INLINEABLE logNotice #-}++logWarning :: MonadLog (WithSeverity a) m => a -> m ()+logWarning   = logMessage . WithSeverity Warning+{-# INLINEABLE logWarning #-}++logError :: MonadLog (WithSeverity a) m => a -> m ()+logError     = logMessage . WithSeverity Error+{-# INLINEABLE logError #-}++logCritical :: MonadLog (WithSeverity a) m => a -> m ()+logCritical  = logMessage . WithSeverity Critical+{-# INLINEABLE logCritical #-}++logAlert :: MonadLog (WithSeverity a) m => a -> m ()+logAlert     = logMessage . WithSeverity Alert+{-# INLINEABLE logAlert #-}++logEmergency :: MonadLog (WithSeverity a) m => a -> m ()+logEmergency = logMessage . WithSeverity Emergency+{-# INLINEABLE logEmergency #-}

+ test/Spec.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+import Control.Monad.Classes hiding (exec)+import Control.Monad.Classes.Log+import Control.Monad.Log (LoggingT, runLoggingT)+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.State (State, execState)++import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $ testCase "should compile" testcase+  where testcase = assertEqual "correct results" [RRes "bar", LRes "foo"] (exec op)++data Foo = Foo String+data Bar = Bar String++data Res = LRes String | RRes String+  deriving (Eq, Ord, Show)++logit :: (MonadReader a m, MonadLog a m) => (a -> a) -> m ()+logit f = ask >>= logMessage . f++-- | This is the operation that will not compile under mtl+-- | due to functional dependencies.+op :: (MonadReader Foo m, MonadReader Bar m, MonadLog Foo m, MonadLog Bar m) => m ()+op = logit (id @Foo) >> logit (id @Bar)++-- | handler for Foo+foo :: MonadState [Res] m => Foo -> m ()+foo (Foo s) = modify $ \r -> LRes s : r++-- | Handler for Bar+bar :: MonadState [Res] m => Bar -> m ()+bar (Bar s) = modify $ \r -> RRes s : r++exec :: ReaderT Foo (ReaderT Bar (LoggingT Foo (LoggingT Bar (State [Res])))) () -> [Res]+exec m = execState (runLoggingT (runLoggingT (runReaderT (runReaderT m (Foo "foo")) (Bar "bar")) foo) bar) []