packages feed

logger (empty) → 0.1.0.0

raw patch · 19 files changed

+1713/−0 lines, 19 filesdep +ansi-wl-pprintdep +basedep +containerssetup-changed

Dependencies added: ansi-wl-pprint, base, containers, lens, mtl, template-haskell, time, transformers, unagi-chan

Files

+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ README.md view
@@ -0,0 +1,2 @@+# haskell-logging+Fast & extensible logging framework for Haskell!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ logger.cabal view
@@ -0,0 +1,91 @@+name:                logger+category:            System+version:             0.1.0.0+license:             Apache-2.0+license-file:        LICENSE+cabal-version:       >=1.10+author:              Wojciech Danilo+maintainer:          Wojciech Danilo <wojciech.danilo@gmail.com>+stability:           provisional+synopsis:            Fast & extensible logging framework+copyright:           Copyright (C) 2015 Wojciech Danilo+tested-with:         GHC == 7.8.3+build-type:          Simple+homepage:            https://github.com/wdanilo/haskell-logger+bug-reports:         https://github.com/wdanilo/haskell-logger/issues++description:         ++  Logging is a fast and extensible Haskell logging framework. +  .+  Logging allows you to log any kind of messages in both IO as well as pure code, depending on the informations you want to log.+  .+  The framework bases on the idea of logger transformer stack defining the way it works. You can build your own stack to highly tailor the behaviour to your needs, starting with such simple things, like logging messages to a list, ending on logging compile-time, priority-filtered messages from different threads and gathering them in other logger thread.+  .+  For detailed documentation and examples look at the ''System.Log'' module.++extra-source-files:  README.md++source-repository head+  type: git+  location: git://github.com/wdanilo/haskell-logger.git++library+  exposed-modules:     +      System.Log, +      System.Log.Tuples, +      System.Log.Simple, +      System.Log.Filter, +      System.Log.Level, +      System.Log.Format, +      System.Log.Data, +      System.Log.Log, +      System.Log.TH, +      System.Log.Logger.Base, +      System.Log.Logger.Writer, +      System.Log.Logger.Thread, +      System.Log.Logger.Priority, +      System.Log.Logger.Handler, +      System.Log.Logger.Drop+  +  -- other-modules:    ++  default-extensions:+      DefaultSignatures,+      ViewPatterns,+      DeriveFunctor,+      TupleSections,+      StandaloneDeriving,+      MultiParamTypeClasses,+      ConstraintKinds,+      FlexibleContexts,+      FlexibleInstances,+      GeneralizedNewtypeDeriving+  +  -- LANGUAGE extensions used by modules in this package.+  other-extensions:+      KindSignatures,+      TypeFamilies,+      FunctionalDependencies,+      UndecidableInstances,+      NoMonomorphismRestriction,+      OverlappingInstances,+      TemplateHaskell,+      CPP,+      OverloadedStrings+  +  build-depends:+      base >=4.7 && <4.8,+      transformers >=0.4 && <0.5,+      time >=1.5 && <1.6,+      ansi-wl-pprint >=0.6 && <0.7,+      lens >=4.6 && <4.7,+      template-haskell >=2.9 && <2.10,+      mtl >=2.2 && <2.3,+      containers >=0.5 && <0.6,+      unagi-chan >=0.3 && <0.4+  +  hs-source-dirs:      src+  +  default-language:    Haskell2010+
+ src/System/Log.hs view
@@ -0,0 +1,376 @@+-----------------------------------------------------------------------------+{- |+   Module      :  System.Log+   Copyright   :  (C) 2015 Flowbox+   License     :  Apache-2.0+   Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+   Stability   :  stable+   Portability :  portable++Written by Wojciech Daniło @ Flowbox.io++= Overview++Logging is a fast and extensible Haskell logging framework. ++Logging allows you to log any kind of messages in both IO as well as pure code, depending on the informations you want to log.++The framework bases on the idea of logger transformer stack defining the way it works. You can build your own stack to highly tailor the behaviour to your needs, starting with such simple things, like logging messages to a list, ending on logging compile-time, priority-filtered messages from different threads and gathering them in other logger thread.++= Documentation++The following documentation describes how to use the framework, how it works under the hood and how can you extend it.++== Basics++This chapter covers all the basic information about logger transformers shipped with the framework.++=== BaseLogger++Let's start with a very simple example:++@+import System.Log.Simple++test = do+    debug "a debug"+    warning "a warning"+    return "Done"++main = print $ runBaseLogger (Lvl, Msg) test+-- output: "Done"+@++There are few things to not here:+    * We are importing the ''System.Log.Simple'' interface. It provides all necessary functions to start with the library. There is other interface, ''System.Log.TH'', which provides simmilar functionality, but allows additionally logging such informations like file or module name and log location inside the file.+    * We are running the logger using 'runBaseLogger' function providing the description what type of information we want to gather with each call to 'debug', 'warning', etc. This is very important, because we can choose only the needed information, like messages and levels and run the logger as a pure code. If you try to run the example with other description, like @(Lvl, Msg, Time)@, it will fail complaining that it needs the 'IO' monad for that.+    * The 'BaseLogger' is the most base logger transformer and it should be run as a base for every logger transformer stack. It do not log any messages under the hood, in fact you cannot do anything sensible with it.++As every logger transformer, 'BaseLogger' has an appriopriate transformer type called 'BaseLoggerT'. You can use it just as every monad transformer, to pipe computations to an underlying monad. Using the transformer we can ask our logger to log also such information as the time:++@+main = print =<< runBaseLogger (Lvl, Msg, Time) test+@++There is one very important design decision. All the logger transformers, appart from the base one, pass the newly registered log to underlying transformers. This way we can create a transformer that writes messages to disk and combine it with the one, that registers the logs in a list. There are some examples showing this behavior later in this document.++=== WriterLogger++'WriterLogger' is just like 'Writer' monad - it gathers all the logs into a list and returns it:+@+main = print $ (runBaseLogger (Lvl, Msg) . runWriterLoggerT) test+@+As a result we get tuple, which first element is the functions return value, while the second is list of all Log messages. For now the log message is not very friendly nested-tuple structure, but it will change in the next versions of the library. To be clear, the single log looks like this at the moment:+@+Log {fromLog = (Data {recBase = Lvl, recData = LevelData 0 "Debug"},(Data {recBase = Msg, recData = "a debug"},()))}+@++WiterLogger should work as fast as just 'WriterT' monad transformer with 'Dlist' used for logs gathering, because there should be no overhead introduced by the library.++=== HandlerLogger++'HandlerLogger' allows you to handle messages using handlers and log formatters. At last we will see something usefull as a logging library! To start, let's look at a simple example:++@+import System.Log.Simple++test = do+    addHandler $ printHandler Nothing+    debug "a debug"+    warning "a warning"++main = print =<< (runBaseLoggerT (Lvl, Msg) . runHandlerLoggerT defaultFormatter) test+@++As a result, we get a colored output (on all platforms, including Windows):++@+[Debug] a debug+[Warning] a warning+"Done"+@++Ok, so what's happening here? The function 'addHandler' registers new log handler in current logger monad. The @Nothing@ just indicates, that this handler does not need any special formatter and can use the default one, provided when executing the monad - in this case, the 'defaultFormatter'. We can of course define our custom message formatters.++For no only the 'printHandler' is provided, but it is straightforward to define custom handlers. Other will be added in the next versions of the library.++==== Formatters++It is possible to define a custom message formatter. To do it, import the module ''System.Log.Format'' and use so called formatter builder. Let's see how the 'defaultFormatter' is defined:++@+defaultFormatter = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Msg+@++You might ask now, what are 'Lvl' or 'Msg'. They are "data pointers". You will learn about them later, for now just remember, you can use them while running loggers as well as defining formatters. There is one very important thing to note here - you cannot use any data provider in your logger, that was not declared to be gathered when the logger is run! In later chapters you will also learn how to create custom data providers.++So what if we would like to output not only the message and it's priority level, but also the module name and location of the message in the source file? Such logger is also defined and it's called 'defaultFormatterTH'. You cannot use it using the 'Simple' interface, so lets see for now how it is defined:++@+defaultFormatterTH = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Loc <:> ": " <:> Msg+@++It's output is simmilar to:++@+[Debug] Main.hs:4: a debug+[Warning] Main.hs:5: a warning+@++=== PriorityLogger++The 'PriorityLogger' is used to filter the messages by priority levels. It is important to note here, that 'PriorityLogger' is able to filter them at compile time, so if we need some IO actions to construct a log, like reading a time or process id, they will not be executed when the priority of such log is too low. Let's see how we can use it:++@+test = do+    addHandler $ printHandler Nothing+    debug "a debug"+    setPriority Debug+    debug "another debug"+    warning "a warning"+    +print =<< ( runBaseLoggerT (Lvl, Msg) +          . runHandlerLoggerT defaultFormatter +          . runPriorityLoggerT Warning +          ) test+@++As the output we get:++@+[Debug] another debug+[Warning] a warning+@++=== ThreadedLogger++The 'ThreadedLogger' is a very fancy one. It allows separate the actual logging from program. Program is being run on a separate thread, while logs are being gathered by the main thread. You can fork the program as many times you want and all the logs will be send to the log-gather routine. This allows to get nicely not-broken output in terminal or in files from different threads. The program stops after all the logs have been processed. Lets look at the example:++@+import           System.Log.Simple+import qualified System.Log.Logger.Thread as Thread+import           Control.Monad.IO.Class (liftIO)++test = do+    addHandler $ printHandler Nothing+    debug "a debug"+    setPriority Debug+    debug "another debug"+    warning "a warning"+    Thread.fork $ do+        liftIO $ print "Threaded print"+        debug "debug in fork"+    liftIO $ print "End of the test!"+    +print =<< ( runBaseLoggerT (Lvl, Msg) +          . runHandlerLoggerT defaultFormatter +          . runPriorityLoggerT Warning +          . runThreadedLogger+          ) test+@++As the output we get:++@+"Threaded print"+"End of the test!"+[Debug] another debug+[Warning] a warning+[Debug] debug in fork+@++The output may of course vary, based on the way threads will be sheduled, because we use 'print' functions here. Anyway you can notice, that the prints were executed at the same time as all the logging.+It is important to use @Thread.fork@, which is just a simple wrapper around 'forkIO'.++==== Exception handling++All the loggers behave in a proper way, when an exception is rised. The exception will be evaluated after all necessary logging has been done:++@+test = do+    addHandler $ printHandler Nothing+    debug "debug"+    Thread.fork $ do+        fail "oh no"+        debug "debug in fork"+    warning "a warning"++print =<< ( runBaseLoggerT (Lvl, Msg) +          . runHandlerLoggerT defaultFormatter +          . runThreadedLogger+          ) test+@++Results in:++@+[Debug] debug+Main.hs: user error (oh no)+@++=== DropLogger++The 'DropLogger' allows you to simply drop all logs from the function. It could be used if you want to execute a subroutine but just discard all logging there. The log messages would be completely discarded - they will not even be created.++== TemplateHaskell interface++You can use more advanced interface to be able to log more information, like module name or file number. To use it, import @System.Log.TH@ instead of @System.Log.Simple@ and use TemplateHaskell syntax to report logs:++@+import System.Log.TH++test = do+    addHandler $ printHandler Nothing+    $(debug "a debug")+    setPriority Debug+    $(debug "another debug")+    $(warning "a warning")++print =<< ( runBaseLoggerT (Lvl, Msg, Loc) +          . runHandlerLoggerT defaultFormatterTH+          . runPriorityLoggerT Warning +          . runThreadedLogger+          ) test+@++Which results in the following output:++@+[Debug] Main:7: another debug+[Warning] Main:8: a warning+@++== Filtering messages++The framework allows you to filter messages after they have been created. It is slower than using 'PriorityLogger' because the messages are created even if they are not needed. It could be used for example in a situation, where you've got many handlers and you want to output only important logs to the screen and all the logs into files. Here's a small example showing how it works.++@+test = do+    addHandler $ addFilter (lvlFilter Warning) $ printHandler Nothing+    $(debug "a debug")+    $(warning "a warning")++print =<< ( runBaseLoggerT (Lvl, Msg, Loc) +          . runHandlerLoggerT defaultFormatterTH+          ) test+@++Which results in:++@+[Warning] Main:5: a warning+@++== Extending the logger++It is possible to extend the logging framework in any way you want. All the functionality you have seen above are just simple logger transformers and you can modify them in a ton of ways or create custom ones.++=== Custom prioritiy levels++Defining a custom priority levels is as easy as creating a new datatype that derives the 'Enum' and start using it. The default prorities are defined as:++@+data Level = Debug     -- ^ Debug Logs+           | Info      -- ^ Information+           | Notice    -- ^ Normal runtime conditions+           | Warning   -- ^ General Warnings+           | Error     -- ^ General Errors+           | Critical  -- ^ Severe situations+           | Alert     -- ^ Take immediate action+           | Panic     -- ^ System is unusable+           deriving (Eq, Ord, Show, Read, Enum)+@++=== Custom data providers++It is possible to define custom data providers. Let's look how the 'Msg' data provided is defined in the library:++@+data Msg = Msg deriving (Show)+type instance DataOf Msg = String+@++That's it. There is no more code for it. After creating such new datatype you can create a pretty printing instance for it and use it just like all other data even in the formatter builder!+But how the data is being registered? Let's look how the 'debug' function is defined in the 'Simple' library:++@+debug = log empty Debug+@++The 'log' function is a very generic one and allows creating almost any logging functionality. If for example we would love to add a new data provider 'Foo' registering an 'Int', we can do this simply by:++@+data Foo = Foo deriving (Show)+type instance DataOf Foo = Int++debugFoo i = log (appData Foo i empty) Debug++instance PPrint Foo where+    pprint = text . show++fooFormatter = defaultFormatter <:> " (" <:> Foo <:> ")"++test = do+    addHandler $ printHandler Nothing+    debugFoo 7 "my custom debug"++print =<< ( runBaseLoggerT (Lvl, Msg, Foo) +          . runHandlerLoggerT defaultFormatter+          ) test+@++Which results in:++@+[Debug] my custom debug (7)+@++==== monad data providers++What happens when such data is not provided when constructing the message? Like 'Time' data? If data is not available at construction time, the logger looks for its 'DataGetter' instance. A simple 'Time' data provider could be defined as:++@+import Data.Time.Clock  (getCurrentTime, UTCTime)+import Data.Time.Format (formatTime, defaultTimeLocale)++data Time = Time deriving (Show)+type instance DataOf Time = UTCTime++instance MonadIO m => DataGetter Time m where+    getData = do liftIO $ Data Time <$> getCurrentTime++instance Pretty UTCTime where+    pretty = text . formatTime defaultTimeLocale "%c"++defaultTimeFormatter = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Time <:> ": " <:> Msg+@++That's it! You can use any function inside - both pure as well as IO. If you use pure function, just return the value. If you will execute 'runBaseLogger' it will be evaluated inside the 'Identity' monad.++=== Custom logger transformers++It's also straightforward to define custom logger transformers. They have to be instances of some datatypes. To know more about it, look at example transformers inside the ''System.Log.Logger'' module.++= Conclusion++This is a new logging library written for purposes of fast logging between threads. It is still under development, so you can expect some api changes. There is still some functionality missing, like file handlers, but as you have seen, it is easy to define such. Any help would be welcome.++Happy logging!++-}++module System.Log (+    module X+) where++import System.Log.Simple as X++test = do+    addHandler $ addFilter (lvlFilter Warning) $ printHandler Nothing+    debug "a debug"+    warning "a warning"++main = do+    print =<< ( runBaseLoggerT (Lvl, Msg, Time) +              . runHandlerLoggerT defaultTimeFormatter+              ) test
+ src/System/Log/Data.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Data+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Data where++import Prelude                hiding (lookup, log)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Concurrent     (threadDelay)+import Control.Applicative    hiding (empty)+import System.Log.Log         (MonadLogger, LogFormat, Log(Log), fromLog, appendLog)+import Data.Time.Clock        (getCurrentTime, UTCTime)+import Control.Lens+++----------------------------------------------------------------------+-- Logging utils+----------------------------------------------------------------------+++log :: (Show pri, Enum pri, MonadRecord (Data Lvl, (Data Msg, r)) m)+    => RecordBuilder r -> pri -> String -> m ()+log rec pri msg = do+#ifdef NOLOGS+    return ()+#else+    appendRecord $ appData Lvl (mkLevel pri)+                 $ appData Msg msg+                 $ rec+#endif+++----------------------------------------------------------------------+-- RecordBuilder+----------------------------------------------------------------------++newtype RecordBuilder a = RecordBuilder { fromRecordBuilder :: a } deriving (Show, Functor)+empty = RecordBuilder ()++class MonadRecord d m where+    appendRecord :: RecordBuilder d -> m ()++    default appendRecord :: (MonadLogger m, LogBuilder d m) => RecordBuilder d -> m ()+    appendRecord d = do+        l <- buildLog d+        appendLog l++appData :: (a~DataOf base) => base -> a -> RecordBuilder as -> RecordBuilder (Data base, as)+appData base a = fmap (Data base a,)+++----------------------------------------------------------------------+-- Basic data wrappers+----------------------------------------------------------------------++data Data base = Data { recBase :: base+                      , recData :: DataOf base+                      }+deriving instance (Show (DataOf base), Show base) => Show (Data base)++class DataGetter base m where+    getData :: m (Data base)++type family DataOf a :: *+++----------------------------------------------------------------------+-- LogBuilder+----------------------------------------------------------------------++class LogBuilderProto a m b where+    buildLogProto :: RecordBuilder a -> m (Log b)++type LogBuilder a m = LogBuilderProto a m (LogFormat m)++buildLog :: (Monad m, Applicative m, LogBuilder a m) => RecordBuilder a -> m (Log (LogFormat m))+buildLog = buildLogProto++-- === Instances ===++instance (LogBuilderProto xs m ys, Functor m) => LogBuilderProto (Data x,xs) m (Data x,ys) where+    buildLogProto b = (fmap.fmap) (x,) $ buildLogProto $ RecordBuilder xs where+        (x,xs) = fromRecordBuilder b++instance (LogBuilderProto (Data x,xs) m ys, LogBuilderProto xs m (Data y,()), Monad m) => LogBuilderProto (Data x,xs) m (Data y,ys) where+    buildLogProto b = do+        let (x,xs) = fromRecordBuilder b+        Log ys     <- buildLogProto b+        Log (y,()) <- buildLogProto $ RecordBuilder xs+        return $ Log (y, ys)+      +instance Monad m => LogBuilderProto a m () where+    buildLogProto _ = return $ Log ()++instance (Functor m, Applicative m, DataGetter y m, LogBuilderProto () m ys) => LogBuilderProto () m (Data y,ys) where+    buildLogProto b = fmap Log $ (,) <$> getData <*> (fromLog <$> buildLogProto b)+++----------------------------------------------------------------------+-- Data reading+----------------------------------------------------------------------++class Lookup base s where +    lookup :: base -> s -> Data base++readData :: Lookup a l => a -> l -> DataOf a+readData a = recData . lookup a++-- === Instances ===++instance LookupDataSet base l => Lookup base (Log l) where+    lookup b (fromLog -> s) = lookupDataSet b s++instance LookupDataSet base r => Lookup base (RecordBuilder r) where+    lookup b (fromRecordBuilder -> r) = lookupDataSet b r++---++class LookupDataSet base s where +    lookupDataSet :: base -> s -> Data base++instance LookupDataSet base (Data base,as) where+    lookupDataSet _ (a,_) = a++instance LookupDataSet base as => LookupDataSet base (Data b,as) where+    lookupDataSet b (_, as) = lookupDataSet b as+++----------------------------------------------------------------------+-- Simple data providers+----------------------------------------------------------------------++-- Time --++data Time = Time deriving (Show)+type instance DataOf Time = UTCTime++instance MonadIO m => DataGetter Time m where+    getData = do liftIO $ Data Time <$> getCurrentTime++-- Msg --++data Msg = Msg deriving (Show)+type instance DataOf Msg = String+++-- Lvl -- ++data Lvl = Lvl deriving (Show)+type instance DataOf Lvl = LevelData+data LevelData = LevelData Int String deriving (Show, Ord, Eq)+mkLevel a = LevelData (fromEnum a) (show a)++-- Loc --++type Pos = (Int, Int)++data LocData = LocData { _filename :: String+                       , _package  :: String+                       , _module   :: String+                       , _start    :: Pos+                       , _end      :: Pos+                       } deriving Show++mkLoc (f,p,m,s,e) = LocData f p m s e++data Loc = Loc deriving (Show)+type instance DataOf Loc = LocData++makeLenses ''Loc
+ src/System/Log/Filter.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Filter+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Filter where++import System.Log.Log (Log)+import System.Log.Data  (Lvl(Lvl), Msg(Msg), LevelData(LevelData), readData, DataOf, Lookup, LookupDataSet)++----------------------------------------------------------------------+-- Filter+----------------------------------------------------------------------++newtype Filter a = Filter { runFilter :: Log a -> Bool }++lvlFilter' :: (LookupDataSet Lvl l, Enum a) => a -> Log l -> Bool+lvlFilter' lvl l = (i >= fromEnum lvl) where+    LevelData i _ = readData Lvl l++lvlFilter lvl = Filter (lvlFilter' lvl)
+ src/System/Log/Format.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Format+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Format where++import System.Log.Log               (Log)+import System.Log.Data              (Lvl(Lvl), Msg(Msg), Loc(Loc), Time(Time), LocData(LocData), LevelData(LevelData), readData, DataOf, Lookup)+import Data.Time.Clock              (UTCTime)+import Data.Time.Format             (formatTime, defaultTimeLocale)+import Text.PrettyPrint.ANSI.Leijen++++----------------------------------------------------------------------+-- Formatter+----------------------------------------------------------------------++newtype Formatter a = Formatter { runFormatter :: Log a -> Doc }++mapFormatter f (Formatter a) = Formatter (f a)+++instance Show (Formatter a) where+    show _ = "Formatter"+++----------------------------------------------------------------------+-- FormatBuilder+----------------------------------------------------------------------++class FormatterBuilder a b where+    buildFormatter :: a -> Formatter b+++(<:>) :: (FormatterBuilder a c, FormatterBuilder b c) => a -> b -> Formatter c+(<:>) a b = concatFormatters (buildFormatter a) (buildFormatter b)++concatFormatters :: Formatter a -> Formatter a -> Formatter a+concatFormatters (Formatter f) (Formatter g) = Formatter (\s -> f s <> g s)++-- === Instances ===++instance (PPrint (DataOf seg), Lookup seg (Log a)) => FormatterBuilder seg a where+    buildFormatter a = Formatter $ pprint . readData a++instance (a~b) => FormatterBuilder (Formatter a) b where+    buildFormatter = id++instance FormatterBuilder String a where+    buildFormatter a = Formatter $ const (text a)++instance FormatterBuilder Doc a where+    buildFormatter a = Formatter $ const a++----------------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------------++class PPrint a where+    pprint :: a -> Doc++instance PPrint String where+    pprint = text++instance Pretty a => PPrint a where+    pprint = pretty++instance Pretty LevelData where+    pretty (LevelData _ name) = text name++instance Pretty LocData where+    pretty (LocData _ _ m (l,_) _) = text (m ++ ":" ++ show l)++instance Pretty UTCTime where+    pretty = text . formatTime defaultTimeLocale "%c"++----------------------------------------------------------------------+-- Basic formatters+----------------------------------------------------------------------++defaultFormatter     = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Msg+defaultTimeFormatter = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Time <:> ": " <:> Msg+defaultFormatterTH   = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Loc <:> ": " <:> Msg++-- Color formatter++colorLvlFormatter f = Formatter (\s -> let (LevelData pr _) = readData Lvl s in lvlColor pr $ runFormatter f s)++lvlColor lvl+    | lvl == 0  = id+    | lvl <= 2  = green+    | lvl == 3  = yellow+    | otherwise = red+
+ src/System/Log/Level.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Level+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Level where++import Prelude hiding (log, lookup)++data Level = Debug     -- ^ Debug Logs+           | Info      -- ^ Information+           | Notice    -- ^ Normal runtime conditions+           | Warning   -- ^ General Warnings+           | Error     -- ^ General Errors+           | Critical  -- ^ Severe situations+           | Alert     -- ^ Take immediate action+           | Panic     -- ^ System is unusable+           deriving (Eq, Ord, Show, Read, Enum)++
+ src/System/Log/Log.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Log+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Log where++import Control.Applicative+++----------------------------------------------------------------------+-- Log+----------------------------------------------------------------------++newtype Log a = Log { fromLog :: a } deriving (Show, Functor)++type family LogFormat (m :: * -> *)++----------------------------------------------------------------------+-- MonadLogger+----------------------------------------------------------------------++class (Monad m, Applicative m) => MonadLogger m where+    appendLog :: Log (LogFormat m) -> m ()++++++++
+ src/System/Log/Logger/Base.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Base+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Base where++import Control.Monad.Trans+import System.Log.Data (Data, MonadRecord(appendRecord))+import Control.Applicative+import System.Log.Tuples+import System.Log.Log (LogFormat, MonadLogger, appendLog)+import Control.Monad.Identity (runIdentity)++----------------------------------------------------------------------+-- BaseLoggerT+----------------------------------------------------------------------++newtype BaseLoggerT l m a = BaseLoggerT { runRawBaseLoggerT :: m a } deriving (Monad, MonadIO, Applicative, Functor) ++runBaseLoggerT :: (Functor m, Monad m) => l -> BaseLoggerT (MapRTuple Data (Tuple2RTuple l)) m a -> m a+runBaseLoggerT _ = runRawBaseLoggerT++runBaseLogger d = runIdentity . runBaseLoggerT d++-- === instances ===++type instance LogFormat (BaseLoggerT l m) = l+++instance (Applicative m, Monad m) => MonadLogger (BaseLoggerT l m) where+	appendLog _ = return ()++instance MonadTrans (BaseLoggerT l) where+    lift = BaseLoggerT++instance Monad m => MonadRecord d (BaseLoggerT l m) where+    appendRecord _ = return ()++
+ src/System/Log/Logger/Drop.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Drop+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Drop where++import           Data.Monoid+import           Control.Applicative+import           System.Log.Data               (MonadRecord(appendRecord), LogBuilder, LookupDataSet, Msg, Lvl)+import           Control.Lens                  hiding (children)+import           System.Log.Log                (Log, MonadLogger(appendLog), LogFormat, LogFormat)+import           Control.Monad.Trans           (lift)+import           Control.Monad.State           (StateT, runStateT)+import qualified Control.Monad.State           as State+import           Control.Monad.IO.Class        (MonadIO, liftIO)+import           Text.PrettyPrint.ANSI.Leijen  (Doc, putDoc)+import           System.Log.Logger.Handler     (MonadLoggerHandler, addHandler)+import           System.Log.Logger.Priority    (MonadPriorityLogger, getPriority, setPriority)+import Control.Monad.Trans (MonadTrans)++----------------------------------------------------------------------+-- DropLogger+----------------------------------------------------------------------++newtype DropLoggerT m a = DropLoggerT { runDropLoggerT :: m a } deriving (Monad, MonadIO, Applicative, Functor)++instance MonadTrans DropLoggerT where+    lift = DropLoggerT++type instance LogFormat (DropLoggerT m) = LogFormat m++instance (Monad m, Applicative m) => MonadLogger (DropLoggerT m) where+    appendLog _ = return ()++instance Monad m => MonadRecord d (DropLoggerT m) where+    appendRecord _ = return ()++instance (Monad m, MonadLoggerHandler h m) => MonadLoggerHandler h (DropLoggerT m) where+    addHandler _ = return ()++instance Monad m => MonadPriorityLogger (DropLoggerT m) where+    getPriority   = return undefined+    setPriority _ = return ()
+ src/System/Log/Logger/Handler.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Handler+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Handler where++import           Data.Monoid+import           Control.Applicative+import           System.Log.Data               (MonadRecord(appendRecord), LogBuilder, LookupDataSet, Msg, Lvl)+import           System.Log.Filter             (Filter, runFilter)+import           Control.Lens                  hiding (children)+import           System.Log.Log                (Log, MonadLogger(appendLog), LogFormat, LogFormat)+import           Control.Monad.Trans           (lift)+import           Control.Monad.State           (StateT, runStateT)+import qualified Control.Monad.State           as State+import           Control.Monad.IO.Class        (MonadIO, liftIO)+import           System.Log.Format             (Formatter, runFormatter, defaultFormatter)+import           Text.PrettyPrint.ANSI.Leijen  (Doc, putDoc)+import Control.Monad.Trans (MonadTrans)+++----------------------------------------------------------------------+-- MonadLoggerHandler+----------------------------------------------------------------------++class MonadLoggerHandler n m | m -> n where+    addHandler :: Handler n (LogFormat m) -> m ()++    default addHandler :: (Monad m, MonadTrans t) => Handler n (LogFormat m) -> t m ()+    addHandler = lift . addHandler++----------------------------------------------------------------------+-- Handler+----------------------------------------------------------------------++-- !!! dorobic formattery i filtracje do handlerow!++data Handler m l = Handler { _name      :: String+                           , _action    :: Doc -> Log l -> m ()+                           , _children  :: [Handler m l]+                           , _formatter :: Maybe (Formatter l)+                           , _filters   :: [Filter l]+                           }+makeLenses ''Handler++type Handler' m = Handler m (LogFormat m)++instance Show (Handler m l) where+    show (Handler n _ _ _ _) = "Handler " <> n++mkHandler :: String -> (Doc -> Log l -> m ()) -> Maybe (Formatter l) -> Handler m l+mkHandler name f fmt = Handler name f [] fmt []+addChildHandler h ph = ph & children %~ (h:)++addFilter :: Filter l -> Handler m l -> Handler m l+addFilter f = filters %~ (f:)++setFormatter :: Formatter l -> Handler m l -> Handler m l+setFormatter f = formatter .~ (Just f)++-- === Handlers ===++topHandler fmt = mkHandler "TopHandler" (\_ _ -> return ()) Nothing+               & formatter .~ (Just fmt)++printHandler = mkHandler "PrintHandler" handle where+    handle defDoc l = liftIO $ putDoc defDoc *> putStrLn ""++----------------------------------------------------------------------+-- HandlerLogger+----------------------------------------------------------------------++newtype HandlerLogger m a = HandlerLogger { fromHandlerLogger :: StateT (Handler' (HandlerLogger m)) m a } deriving (Monad, MonadIO, Applicative, Functor)++type instance LogFormat (HandlerLogger m) = LogFormat m++instance MonadTrans HandlerLogger where+    lift = HandlerLogger . lift++runHandlerLoggerT :: (Functor m, Monad m) => Formatter (LogFormat m) -> HandlerLogger m b -> m b+runHandlerLoggerT fmt = fmap fst . flip runStateT (topHandler fmt) . fromHandlerLogger+++runHandler :: (Applicative m, Monad m) => Doc -> Log (LogFormat m) -> Handler' m -> m ()+runHandler defDoc l h = act <* mapM (runHandler doc l) (h^.children) where+    flt = runFilters h l+    fmt = h^.formatter+    act = if flt then (h^.action) doc l+                 else return ()+    doc = case fmt of+        Nothing -> defDoc+        Just f  -> runFormatter f l+    runFilters h l = foldr (&&) True $ fmap (\f -> runFilter f l) (h^.filters)+++getTopHandler = HandlerLogger State.get+putTopHandler = HandlerLogger . State.put++-- === Instances ===++instance (MonadLogger m, Functor m, l~LogFormat m, LookupDataSet Msg l, LookupDataSet Lvl l)+      => MonadLogger (HandlerLogger m) where+    appendLog l =  (runHandler defDoc l =<< getTopHandler) +                *> lift (appendLog l)+        where defDoc = runFormatter defaultFormatter l++instance (Monad m, Functor m) => MonadLoggerHandler (HandlerLogger m) (HandlerLogger m) where+    addHandler h = do+        topH <- getTopHandler+        putTopHandler $ addChildHandler h topH++instance (Functor m, MonadLogger m, l~LogFormat m, LogBuilder d (HandlerLogger m), LookupDataSet Msg l, LookupDataSet Lvl l) +      => MonadRecord d (HandlerLogger m)
+ src/System/Log/Logger/Priority.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Handler+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Priority where++import System.Log.Data           (MonadRecord, appendRecord, Lvl(Lvl), readData, LevelData(LevelData), LookupDataSet)+import System.Log.Logger.Handler (MonadLoggerHandler(addHandler))+import System.Log.Log            (MonadLogger, LogFormat)+import Control.Monad.State       (StateT, runStateT)+import Control.Monad.Trans       (MonadTrans, lift)+import Control.Monad.IO.Class    (MonadIO)+import Control.Applicative+import qualified Control.Monad.State as State++----------------------------------------------------------------------+-- MonadPriorityLogger+----------------------------------------------------------------------++class MonadPriorityLogger m where+    getPriority :: m Int+    setPriority :: Enum a => a -> m ()++----------------------------------------------------------------------+-- PriorityLoggerT+----------------------------------------------------------------------++newtype PriorityLoggerT m a = PriorityLoggerT { fromPriorityLoggerT :: StateT Int m a } deriving (Monad, MonadIO, Applicative, Functor, MonadTrans)+type instance LogFormat (PriorityLoggerT m) = LogFormat m++runPriorityLoggerT pri = fmap fst . flip runStateT (fromEnum pri) . fromPriorityLoggerT+++-- === Instances ===++instance Monad m => MonadPriorityLogger (PriorityLoggerT m) where+    getPriority   = PriorityLoggerT State.get+    setPriority a = PriorityLoggerT . State.put $ fromEnum a++instance (MonadLogger m, MonadRecord d m, LookupDataSet Lvl d) => MonadRecord d (PriorityLoggerT m) where+    appendRecord d = do+        priLimit <- getPriority+        let LevelData pri _ = readData Lvl d+        if priLimit <= pri then lift $ appendRecord d+                           else return ()++instance (Monad m, MonadLoggerHandler h m) => MonadLoggerHandler h (PriorityLoggerT m)
+ src/System/Log/Logger/Thread.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Handler+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Thread where++import           System.Log.Data               (MonadRecord, appendRecord, Lvl(Lvl), readData, LevelData(LevelData), LookupDataSet)+import           System.Log.Logger.Handler     (MonadLoggerHandler(addHandler))+import           System.Log.Log                (LogFormat, MonadLogger)+import           System.Log.Logger.Base        (BaseLoggerT, runRawBaseLoggerT)+import           System.Log.Logger.Priority    (MonadPriorityLogger(getPriority,setPriority))+import           Control.Monad.Trans           (MonadTrans, lift)+import           Control.Monad.IO.Class        (MonadIO, liftIO)+import           Control.Applicative+import qualified Control.Monad.Reader          as Reader+import           Control.Monad.Reader          (ReaderT, runReaderT)+import           Control.Concurrent.Chan.Unagi (readChan, writeChan, newChan, InChan, OutChan)+import           Control.Exception             (throwIO, catch, SomeException)+import           Control.Concurrent            (forkIO)+import           Control.Concurrent.MVar       (newEmptyMVar, putMVar, takeMVar)+++----------------------------------------------------------------------+-- ThreadedLogger+----------------------------------------------------------------------++newtype ThreadedLogger' d r m a = ThreadedLogger' { fromThreadedLogger :: ReaderT (InChan (ChMsg d r)) m a } deriving (Monad, MonadIO, Applicative, Functor, MonadTrans)+type ThreadedLogger d m a = ThreadedLogger' d a m a+type instance LogFormat (ThreadedLogger' d r m) = LogFormat m++data ChMsg m a = ChMsg (m ()) | End a | Exc SomeException++class MonadThreadLogger m n a | m-> n a where+    getLogChan :: m (InChan (ChMsg n a))++-- === Utils ===++runRawThreadedLogger :: InChan (ChMsg d r) -> ThreadedLogger' d r m a -> m a+runRawThreadedLogger ch = flip runReaderT ch . fromThreadedLogger++-- cutting out all the logs and sending them over channel, computing result+runRawBaseThreadedLogger :: InChan (ChMsg d r) -> ThreadedLogger' d r (BaseLoggerT l m) a -> m a+runRawBaseThreadedLogger ch = runRawBaseLoggerT . runRawThreadedLogger ch++runThreadedLogger :: (MonadIO m, Applicative m) => ThreadedLogger m (BaseLoggerT l IO) a -> m a+runThreadedLogger m = do+    (inChan, outChan) <- liftIO newChan+    liftIO $ forkIO $ do+        out <- (End <$> runRawBaseThreadedLogger inChan m) `catch` (\e -> return (Exc e))+        writeChan inChan out+    loop outChan+    where loop :: (MonadIO m, Applicative m) => OutChan (ChMsg m a) -> m a+          loop ch = do+              l <- liftIO $ readChan ch+              case l of+                  End   a -> return a+                  ChMsg d -> d *> loop ch+                  Exc   e -> liftIO $ throwIO e++liftIOThread :: (MonadIO m, MonadThreadLogger m n a) => (IO () -> IO fa) -> ThreadedLogger' n a (BaseLoggerT l IO) b -> m b+liftIOThread f m = do+    inChan <- getLogChan+    ret    <- liftIO $ newEmptyMVar+    liftIO . f $ do+        out <- (End <$> runRawBaseThreadedLogger inChan m) `catch` (\e -> return (Exc e))+        case out of+            End v -> putMVar ret v+            Exc e -> putMVar ret undefined *> writeChan inChan (Exc e)+    liftIO $ takeMVar ret++fork :: (MonadIO m, MonadThreadLogger m n a) => ThreadedLogger' n a (BaseLoggerT l IO) b -> m b+fork = liftIOThread forkIO++withTarget :: (MonadThreadLogger m n a, MonadIO m) => n () -> m ()+withTarget f = do+    ch <- getLogChan+    liftIO $ writeChan ch (ChMsg f)++-- === Instances ===++instance Monad m => MonadThreadLogger (ThreadedLogger' d r m) d r where+    getLogChan = ThreadedLogger' Reader.ask++---++instance (MonadIO m, MonadRecord d n) => MonadRecord d (ThreadedLogger' n a m) where+    appendRecord = withTarget . appendRecord++instance (MonadIO m, MonadLoggerHandler h d, LogFormat m ~ LogFormat d) => MonadLoggerHandler h (ThreadedLogger' d a m) where+    addHandler = withTarget . addHandler++instance (MonadIO m, MonadPriorityLogger d) => MonadPriorityLogger (ThreadedLogger' d a m) where+    setPriority = withTarget . setPriority+    getPriority = error "Cannot get priority from within ThreadLogger!"
+ src/System/Log/Logger/Writer.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Logger.Writer+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Logger.Writer where++import           Data.Monoid+import           Data.Sequence          (Seq, (|>))+import           System.Log.Log         (Log, MonadLogger, LogFormat, appendLog)+import           System.Log.Logger.Handler (MonadLoggerHandler)+import qualified Control.Monad.State    as State+import           Control.Monad.State    (StateT, runStateT)+import           Control.Applicative+import           Control.Monad.IO.Class (MonadIO)+import           System.Log.Data        (MonadRecord, LogBuilderProto)+import           Control.Monad.Trans    (MonadTrans, lift)++----------------------------------------------------------------------+-- WriterLogger+----------------------------------------------------------------------++type Logs m = Seq (Log (LogFormat m))++newtype WriterLogger m a = WriterLogger { fromWriterLogger :: StateT (Logs m) m a } deriving (Monad, MonadIO, Applicative, Functor)++instance MonadTrans WriterLogger where+    lift = WriterLogger . lift++type instance LogFormat (WriterLogger m) = LogFormat m++--runWriterLoggerT :: (Functor m, Monad m) => WriterLogger m b -> m b+runWriterLoggerT = flip runStateT mempty . fromWriterLogger++class MonadWriterLogger m where+    getLogs :: m (Logs m)+    putLogs :: Logs m -> m ()++instance Monad m => MonadWriterLogger (WriterLogger m) where+    getLogs = WriterLogger State.get+    putLogs = WriterLogger . State.put++withLogs f = do+    logs <- getLogs+    putLogs $ f logs++instance (Monad m, Functor m, LogBuilderProto d (WriterLogger m) (LogFormat m), MonadLogger m)+      => MonadRecord d (WriterLogger m)++instance (Functor m, Monad m, MonadLogger m) => MonadLogger (WriterLogger m) where+    appendLog l =  withLogs (|> l)+                *> lift (appendLog l)++instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (WriterLogger m)
+ src/System/Log/Simple.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Simple+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.Simple (+	module System.Log.Simple,+	module X+) where++import System.Log.Level           as X+import System.Log.Log             as X+import System.Log.Data            as X+import System.Log.Format          as X+import System.Log.Logger.Base     as X+import System.Log.Logger.Handler  as X+import System.Log.Logger.Priority as X+import System.Log.Logger.Thread   as X+import System.Log.Logger.Drop     as X+import System.Log.Filter          as X+import System.Log.Logger.Writer   as X++import Prelude          hiding (log)+import System.Log.Level+import System.Log.Data  (log, empty)++simpleLog = log empty++debug     = simpleLog Debug+info      = simpleLog Info+notice    = simpleLog Notice+warning   = simpleLog Warning+error     = simpleLog Error+critical  = simpleLog Critical+alert     = simpleLog Alert+panic     = simpleLog Panic
+ src/System/Log/TH.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Log.Simple+-- Copyright   :  (C) 2015 Flowbox+-- License     :  Apache-2.0+-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>+-- Stability   :  stable+-- Portability :  portable+-----------------------------------------------------------------------------++module System.Log.TH (+	module System.Log.TH,+	module X+)where++import System.Log.Level           as X+import System.Log.Log             as X+import System.Log.Data            as X+import System.Log.Format          as X+import System.Log.Logger.Base     as X+import System.Log.Logger.Handler  as X+import System.Log.Logger.Priority as X+import System.Log.Logger.Thread   as X+import System.Log.Logger.Drop     as X+import System.Log.Filter          as X+import System.Log.Logger.Writer   as X++import Language.Haskell.TH++getLoc = do+    loc <- location+    let locCons = TupE [ LitE . StringL . loc_filename $ loc+                       , LitE . StringL . loc_package  $ loc+                       , LitE . StringL . loc_module   $ loc+                       , TupE [ LitE . IntegerL . toInteger . fst . loc_start $ loc+                              , LitE . IntegerL . toInteger . snd . loc_start $ loc+                              ]+                       , TupE [ LitE . IntegerL . toInteger . fst . loc_end $ loc+                              , LitE . IntegerL . toInteger . snd . loc_end $ loc+                              ]+                       ]++    return $ AppE (VarE $ mkName "mkLoc") locCons++logN     = VarE (mkName "log")+emptyN   = VarE (mkName "empty")+appDataN = VarE (mkName "appData")+locN     = ConE (mkName "Loc")++debugN    = ConE (mkName "Debug")+infoN     = ConE (mkName "Info")+noticeN   = ConE (mkName "Notice")+warningN  = ConE (mkName "Warning")+errorN    = ConE (mkName "Error")+criticalN = ConE (mkName "Critical")+alertN    = ConE (mkName "Alert")+panicN    = ConE (mkName "Panic")++debug    = mkLog debugN+info     = mkLog infoN+notice   = mkLog noticeN+warning  = mkLog warningN+error    = mkLog errorN+critical = mkLog criticalN+alert    = mkLog alertN+panic    = mkLog panicN++mkLog eName msg = do+	d <- mkBaseData+	return $ AppE (AppE (AppE logN d) eName) (LitE $ StringL msg)++mkBaseData = do+	loc <- getLoc+	return $ AppE (AppE (AppE appDataN locN) loc) emptyN++--debug     = simpleLog Debug+--info      = simpleLog Info+--notice    = simpleLog Notice+--warning   = simpleLog Warning+--error     = simpleLog Error+--critical  = simpleLog Critical+--alert     = simpleLog Alert+--panic     = simpleLog Panic++--locatedError :: Loc -> Q Exp+--locatedError loc = do+--    let postfix = " at " ++ formatLoc loc+--    [| \msg -> error (msg ++ $(litE $ stringL postfix)) |]++--formatLoc :: Loc -> String+--formatLoc loc = let file = loc_filename loc+--                    (line, col) = loc_start loc+--                in concat [file, ":", show line, ":", show col]++
+ src/System/Log/Tuples.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++module System.Log.Tuples where++type family Tuple2RTuple a where+    Tuple2RTuple ()                               = ()+    Tuple2RTuple (t1,t2)                          = (t1,(t2,()))+    Tuple2RTuple (t1,t2,t3)                       = (t1,(t2,(t3,())))+    Tuple2RTuple (t1,t2,t3,t4)                    = (t1,(t2,(t3,(t4,()))))+    Tuple2RTuple (t1,t2,t3,t4,t5)                 = (t1,(t2,(t3,(t4,(t5,())))))+    Tuple2RTuple (t1,t2,t3,t4,t5,t6)              = (t1,(t2,(t3,(t4,(t5,(t6,()))))))+    Tuple2RTuple (t1,t2,t3,t4,t5,t6,t7)           = (t1,(t2,(t3,(t4,(t5,(t6,(t7,())))))))+    Tuple2RTuple (t1,t2,t3,t4,t5,t6,t7,t8)        = (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,()))))))))+    Tuple2RTuple (t1,t2,t3,t4,t5,t6,t7,t8,t9)     = (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,())))))))))+    Tuple2RTuple (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10) = (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,()))))))))))+    Tuple2RTuple t                                = (t,())++type family RTuple2Tuple a where+    RTuple2Tuple ()                                                    = ()+    RTuple2Tuple (t1,(t2,()))                                          = (t1,t2)+    RTuple2Tuple (t1,(t2,(t3,())))                                     = (t1,t2,t3)+    RTuple2Tuple (t1,(t2,(t3,(t4,()))))                                = (t1,t2,t3,t4)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,())))))                           = (t1,t2,t3,t4,t5)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,(t6,()))))))                      = (t1,t2,t3,t4,t5,t6)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,())))))))                 = (t1,t2,t3,t4,t5,t6,t7)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,()))))))))            = (t1,t2,t3,t4,t5,t6,t7,t8)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,())))))))))       = (t1,t2,t3,t4,t5,t6,t7,t8,t9)+    RTuple2Tuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,())))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10)+    RTuple2Tuple (t,())                                                = t++++type family Insert t set where+  Insert t ()    = (t,())+  Insert t (t,x) = (t,x)+  Insert t (a,x) = (a,Insert t x)+++type family MapRTuple (f :: * -> *) tup where+    MapRTuple f () = ()+    MapRTuple f (a,as) = (f a, MapRTuple f as)++class MapRTuple2 f tup tup' | f tup -> tup'+    where mapRTuple :: f -> tup -> tup'++instance MapRTuple2 f () () where+    mapRTuple _ = id++instance MapRTuple2 (a -> b) as bs => MapRTuple2 (a -> b) (a,as) (b,bs) where+    mapRTuple f (a,as) = (f a, mapRTuple f as)