├── .github
    ├── CODEOWNERS
    ├── dependabot.yml
    └── workflows
    │   ├── publish.yaml
    │   └── ci.yml
├── shell.nix
├── test
    └── Doctests.hs
├── .gitignore
├── .headroom.yaml
├── src
    └── Colog
    │   ├── Core.hs
    │   └── Core
    │       ├── Class.hs
    │       ├── Severity.hs
    │       ├── IO.hs
    │       └── Action.hs
├── README.md
├── co-log-core.cabal
├── CHANGELOG.md
└── LICENSE


/.github/CODEOWNERS:
--------------------------------------------------------------------------------
1 | * @alaendle @vrom911
2 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
1 | with (import <nixpkgs> {});
2 | mkShell {
3 |   buildInputs = [
4 |     gmp
5 |   ];
6 | }
7 | 


--------------------------------------------------------------------------------
/.github/dependabot.yml:
--------------------------------------------------------------------------------
 1 | version: 2
 2 | updates:
 3 |   - package-ecosystem: "github-actions"
 4 |     directory: "/"
 5 |     schedule:
 6 |       interval: "daily"
 7 |     commit-message:
 8 |       prefix: "GA"
 9 |       include: "scope"
10 |     labels:
11 |       - "CI"
12 |       - "dependencies"


--------------------------------------------------------------------------------
/test/Doctests.hs:
--------------------------------------------------------------------------------
 1 | module Main
 2 |        ( main
 3 |        ) where
 4 | 
 5 | import System.FilePath.Glob (glob)
 6 | import Test.DocTest (doctest)
 7 | 
 8 | main :: IO ()
 9 | main = do
10 |     sourceFiles <- glob "src/**/*.hs"
11 |     doctest
12 |         $ "-XDerivingStrategies"
13 |         : "-XInstanceSigs"
14 |         : "-XScopedTypeVariables"
15 |         : "-XViewPatterns"
16 |         : sourceFiles
17 | 


--------------------------------------------------------------------------------
/.github/workflows/publish.yaml:
--------------------------------------------------------------------------------
 1 | name: publish
 2 | 
 3 | on:
 4 |   push:
 5 |     branches:
 6 |       - main
 7 | 
 8 | permissions:
 9 |   contents: write
10 | 
11 | jobs:
12 |   publish:
13 |     runs-on: ubuntu-latest
14 |     steps:
15 |       - uses: actions/checkout@v6
16 | 
17 |       - run: cabal check
18 | 
19 |       - uses: sol/haskell-autotag@v1
20 |         id: autotag
21 |         with:
22 |           prefix: v
23 | 
24 |       - run: cabal sdist
25 |       - uses: haskell-actions/hackage-publish@v1.1
26 |         with:
27 |           hackageToken: ${{ secrets.HACKAGE_AUTH_TOKEN }}
28 |           publish: true
29 |         if: steps.autotag.outputs.created
30 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | ### Haskell
 2 | dist
 3 | dist-*
 4 | cabal-dev
 5 | *.o
 6 | *.hi
 7 | *.chi
 8 | *.chs.h
 9 | *.dyn_o
10 | *.dyn_hi
11 | *.prof
12 | *.aux
13 | *.hp
14 | *.eventlog
15 | .virtualenv
16 | .hsenv
17 | .hpc
18 | .cabal-sandbox/
19 | cabal.sandbox.config
20 | cabal.config
21 | cabal.project.local
22 | .ghc.environment.*
23 | .HTF/
24 | # Stack
25 | .stack-work/
26 | stack.yaml.lock
27 | 
28 | ### IDE/support
29 | # Vim
30 | [._]*.s[a-v][a-z]
31 | [._]*.sw[a-p]
32 | [._]s[a-v][a-z]
33 | [._]sw[a-p]
34 | *~
35 | tags
36 | 
37 | # IntellijIDEA
38 | .idea/
39 | .ideaHaskellLib/
40 | *.iml
41 | 
42 | # Atom
43 | .haskell-ghc-mod.json
44 | 
45 | # VS
46 | .vscode/
47 | 
48 | # Emacs
49 | *#
50 | .dir-locals.el
51 | TAGS
52 | 
53 | # other
54 | .DS_Store
55 | 
56 | # co-log
57 | *.log


--------------------------------------------------------------------------------
/.headroom.yaml:
--------------------------------------------------------------------------------
 1 | ## This is the configuration file for Headroom.
 2 | ## See https://github.com/vaclavsvejcar/headroom for more details.
 3 | version: 0.4.0.0
 4 | 
 5 | run-mode: replace
 6 | 
 7 | source-paths:
 8 |   - src/
 9 | 
10 | excluded-paths: []
11 | 
12 | template-paths:
13 |   - https://raw.githubusercontent.com/co-log/.github/chshersh/2-Headroom-template/headroom-templates/haskell.mustache
14 | 
15 | variables:
16 |   author: Co-Log
17 |   email: xrom.xkov@gmail.com
18 |   _haskell_module_copyright: "(c) {{ _current_year }} {{ author }}"
19 | 
20 | license-headers:
21 |   haskell:
22 |     put-after: ["^{-#"]
23 |     margin-bottom-code: 1
24 |     margin-top-code: 1
25 |     block-comment:
26 |       starts-with: ^{- \|
27 |       ends-with: (?<!#)-}$
28 | 
29 | post-process:
30 |   update-copyright:
31 |     enabled: true
32 |     config:
33 |       selected-authors-only: ["{{ author }}"]
34 | 


--------------------------------------------------------------------------------
/src/Colog/Core.hs:
--------------------------------------------------------------------------------
 1 | {- |
 2 | Module                  : Colog.Core
 3 | Copyright               : (c) 2018-2020 Kowainik, 2021-2025 Co-Log
 4 | SPDX-License-Identifier : MPL-2.0
 5 | Maintainer              : Co-Log <xrom.xkov@gmail.com>
 6 | Stability               : Stable
 7 | Portability             : Portable
 8 | 
 9 | Exports all core functionality. @co-log-core@ is a lightweight package that
10 | defines only core data type and various combinators to work with it.
11 | 
12 | Fundamentals of @co-log-core@ are based on the following data type:
13 | 
14 | @
15 | __newtype__ LogAction m msg = LogAction
16 |     { unLogAction :: msg -> m ()
17 |     }
18 | @
19 | 
20 | This data type provides extremely composable and flexible interface by having
21 | many instances of the standard algebraic data types.
22 | 
23 | The package has the following structure:
24 | 
25 | * __"Colog.Core.Action":__ definition of the main data type and its combinators.
26 | * __"Colog.Core.Class":__ 'HasLog' typeclass that describes how different values
27 |   (e.g. application environment) can store and modify 'LogAction'.
28 | * __"Colog.Core.IO":__ basic loggers that work with 'Control.Monad.IO.Class.MonadIO' and 'String'.
29 | * __"Colog.Core.Severity":__ logger severity.
30 | -}
31 | 
32 | module Colog.Core
33 |        ( module Colog.Core.Action
34 |        , module Colog.Core.Class
35 |        , module Colog.Core.IO
36 |        , module Colog.Core.Severity
37 |        ) where
38 | 
39 | import Colog.Core.Action
40 | import Colog.Core.Class
41 | import Colog.Core.IO
42 | import Colog.Core.Severity
43 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # co-log-core
 2 | 
 3 | ![Co-logo](https://user-images.githubusercontent.com/8126674/80955687-92f21a80-8df7-11ea-90d3-422dafdc8391.png)
 4 | 
 5 | [![GitHub CI](https://github.com/co-log/co-log-core/workflows/CI/badge.svg)](https://github.com/co-log/co-log-core/actions)
 6 | [![Hackage][hk-img-core]][hk-core]
 7 | [![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/co-log/co-log/blob/main/LICENSE)
 8 | 
 9 | `co-log-core` is a lightweight package that provides core types and functions to 
10 | work with the @LogAction@ data type which is both simple and powerful.
11 | 
12 | ## How to use
13 | 
14 | `co-log-core` is compatible with the following GHC
15 | versions - [supported versions](https://matrix.hackage.haskell.org/#/package/co-log-core)
16 | 
17 | In order to start using `co-log-core` in your project, you
18 | will need to set it up with these steps:
19 | 
20 | 1. Add the dependency on `co-log-core` in your project's
21 |    `.cabal` file. For this, you should modify the `build-depends`
22 |    section according to the below section:
23 | 
24 |    ```haskell
25 |    build-depends: base ^>= LATEST_SUPPORTED_BASE
26 |                 , co-log-core ^>= LATEST_VERSION
27 |    ```
28 | 
29 | 2. To use this package, refer to the below example.
30 | 
31 |    ```haskell
32 |    module Main (main) where
33 | 
34 |    import Prelude hiding (log)
35 | 
36 |    import Colog.Core (LogAction, logStringStdout, (<&))
37 | 
38 | 
39 |    app :: LogAction IO String -> IO ()
40 |    app log = do
41 |        log <& "Starting app..."
42 |        log <& "Finishing app..."
43 | 
44 |    main :: IO ()
45 |    main = app logStringStdout
46 |    ```
47 |  
48 |  
49 | [hk-img-core]: https://img.shields.io/hackage/v/co-log-core.svg?logo=haskell
50 | [hk-core]: https://hackage.haskell.org/package/co-log-core
51 | 


--------------------------------------------------------------------------------
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
  1 | name: CI
  2 | 
  3 | on:
  4 |   workflow_dispatch:
  5 |   pull_request:
  6 |     types: [synchronize, opened, reopened]
  7 |   push:
  8 |     branches: [main]
  9 |   schedule:
 10 |     # additionally run once per week (At 00:00 on Sunday) to maintain cache
 11 |     - cron: '0 0 * * 0'
 12 | 
 13 | permissions:
 14 |   contents: read
 15 | 
 16 | jobs:
 17 |   cabal:
 18 |     name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
 19 |     runs-on: ${{ matrix.os }}
 20 |     strategy:
 21 |       fail-fast: false
 22 |       matrix:
 23 |         os: [ubuntu-latest, macOS-latest, windows-latest]
 24 |         cabal: ['latest']
 25 |         ghc:
 26 |           - '8.2.2'
 27 |           - '8.4.4'
 28 |           - '8.6.5'
 29 |           - '8.8.4'
 30 |           - '8.10.7'
 31 |           - '9.0.2'
 32 |           - '9.2.8'
 33 |           - '9.4.8'
 34 |           - '9.6.7'
 35 |           - '9.8.4'
 36 |           - '9.10.2'
 37 |           - '9.12.2'
 38 |         exclude:
 39 |           - os: macOS-latest
 40 |             ghc: 9.10.2
 41 |           - os: macOS-latest
 42 |             ghc: 9.8.4
 43 |           - os: macOS-latest
 44 |             ghc: 9.6.7
 45 |           - os: macOS-latest
 46 |             ghc: 9.4.8
 47 |           - os: macOS-latest
 48 |             ghc: 9.2.8
 49 |           - os: macOS-latest
 50 |             ghc: 9.0.2
 51 |           - os: macOS-latest
 52 |             ghc: 8.10.7
 53 |           - os: macOS-latest
 54 |             ghc: 8.8.4
 55 |           - os: macOS-latest
 56 |             ghc: 8.6.5
 57 |           - os: macOS-latest
 58 |             ghc: 8.4.4
 59 |           - os: macOS-latest
 60 |             ghc: 8.2.2
 61 | 
 62 |           - os: windows-latest
 63 |             ghc: 9.10.2
 64 |           - os: windows-latest
 65 |             ghc: 9.8.4
 66 |           - os: windows-latest
 67 |             ghc: 9.6.7
 68 |           - os: windows-latest
 69 |             ghc: 9.4.8
 70 |           - os: windows-latest
 71 |             ghc: 9.2.8
 72 |           - os: windows-latest
 73 |             ghc: 9.0.2
 74 |           - os: windows-latest
 75 |             ghc: 8.10.7
 76 |           - os: windows-latest
 77 |             ghc: 8.8.4
 78 |           - os: windows-latest
 79 |             ghc: 8.6.5
 80 |           - os: windows-latest
 81 |             ghc: 8.4.4
 82 |           - os: windows-latest
 83 |             ghc: 8.2.2
 84 | 
 85 |     steps:
 86 |       - uses: actions/checkout@v6
 87 | 
 88 |       - uses: haskell-actions/setup@v2
 89 |         id: setup-haskell-cabal
 90 |         name: Setup Haskell
 91 |         with:
 92 |           ghc-version: ${{ matrix.ghc }}
 93 |           cabal-version: ${{ matrix.cabal }}
 94 | 
 95 |       - name: Configure
 96 |         run: |
 97 |           cabal configure --enable-tests --enable-benchmarks --enable-documentation --test-show-details=direct --write-ghc-environment-files=always
 98 | 
 99 |       - name: Freeze
100 |         run: |
101 |           cabal freeze
102 | 
103 |       - uses: actions/cache@v5
104 |         name: Cache ~/.cabal/store
105 |         with:
106 |           path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
107 |           key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
108 | 
109 |       - name: Install dependencies
110 |         run: |
111 |           cabal build all --only-dependencies
112 | 
113 |       - name: Build
114 |         run: |
115 |           cabal build all
116 | 
117 |       - name: Test
118 |         run: |
119 |           cabal test all
120 | 
121 |       - name: Documentation
122 |         run: |
123 |           cabal haddock
124 | 


--------------------------------------------------------------------------------
/src/Colog/Core/Class.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances     #-}
  2 | {-# LANGUAGE MultiParamTypeClasses #-}
  3 | {-# LANGUAGE Rank2Types            #-}
  4 | 
  5 | {- |
  6 | Module                  : Colog.Core.Class
  7 | Copyright               : (c) 2018-2020 Kowainik, 2021-2025 Co-Log
  8 | SPDX-License-Identifier : MPL-2.0
  9 | Maintainer              : Co-Log <xrom.xkov@gmail.com>
 10 | Stability               : Stable
 11 | Portability             : Portable
 12 | 
 13 | Provides type class for values that has access to 'LogAction'.
 14 | -}
 15 | 
 16 | module Colog.Core.Class
 17 |        ( HasLog (..)
 18 | 
 19 |          -- * Lens
 20 |          -- $lens
 21 |        , Lens'
 22 |        ) where
 23 | 
 24 | import Colog.Core.Action  (LogAction)
 25 | import Data.Functor.Const (Const (..))
 26 | 
 27 | 
 28 | -- to inline lens better
 29 | {- HLINT ignore "Redundant lambda" -}
 30 | 
 31 | {- | This types class contains simple pair of getter-setter and related
 32 | functions.
 33 | It also provides the useful lens 'logActionL' with the default implementation using type
 34 | class methods. The default one could be easily overritten under your instances.
 35 | 
 36 | Every instance of the this typeclass should satisfy the following laws:
 37 | 
 38 | 1. __Set-Get:__ @'getLogAction' ('setLogAction' l env) ≡ l@
 39 | 2. __Get-Set:__ @'setLogAction' ('getLogAction' env) env ≡ env@
 40 | 3. __Set-Set:__ @'setLogAction' l2 ('setLogAction' l1 env) ≡ 'setLogAction' l2 env@
 41 | 4. __Set-Over:__ @'overLogAction' f env ≡ 'setLogAction' (f $ 'getLogAction' env) env@
 42 | -}
 43 | class HasLog env msg m where
 44 |     {-# MINIMAL logActionL | (getLogAction , (setLogAction | overLogAction)) #-}
 45 | 
 46 |     -- | Extracts 'LogAction' from the environment.
 47 |     getLogAction :: env -> LogAction m msg
 48 |     getLogAction = getConst . logActionL Const
 49 |     {-# INLINE getLogAction #-}
 50 | 
 51 |     -- | Sets 'LogAction' to the given one inside the environment.
 52 |     setLogAction :: LogAction m msg -> env -> env
 53 |     setLogAction = overLogAction . const
 54 |     {-# INLINE setLogAction #-}
 55 | 
 56 |     -- | Applies function to the 'LogAction' inside the environment.
 57 |     overLogAction :: (LogAction m msg -> LogAction m msg) -> env -> env
 58 |     overLogAction f env = setLogAction (f $ getLogAction env) env
 59 |     {-# INLINE overLogAction #-}
 60 | 
 61 |     -- | Lens for 'LogAction' inside the environment.
 62 |     logActionL :: Lens' env (LogAction m msg)
 63 |     logActionL = lens getLogAction (flip setLogAction)
 64 |     {-# INLINE logActionL #-}
 65 | 
 66 | instance HasLog (LogAction m msg) msg m where
 67 |     getLogAction :: LogAction m msg -> LogAction m msg
 68 |     getLogAction = id
 69 |     {-# INLINE getLogAction #-}
 70 | 
 71 |     setLogAction :: LogAction m msg -> LogAction m msg -> LogAction m msg
 72 |     setLogAction = const
 73 |     {-# INLINE setLogAction #-}
 74 | 
 75 |     overLogAction
 76 |         :: (LogAction m msg -> LogAction m msg)
 77 |         -> LogAction m msg
 78 |         -> LogAction m msg
 79 |     overLogAction = id
 80 |     {-# INLINE overLogAction #-}
 81 | 
 82 |     logActionL :: Lens' (LogAction m msg) (LogAction m msg)
 83 |     logActionL = \f s -> s <$ f s
 84 |     {-# INLINE logActionL #-}
 85 | 
 86 | ----------------------------------------------------------------------------
 87 | -- Lens
 88 | ----------------------------------------------------------------------------
 89 | 
 90 | {- $lens
 91 | To keep @co-log-core@ a lightweight library it was decided to introduce local
 92 | 'Lens'' type alias as it doesn't harm.
 93 | -}
 94 | 
 95 | {- | The monomorphic lenses which don't change the type of the container (or of
 96 | the value inside).
 97 | -}
 98 | type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
 99 | 
100 | -- | Creates 'Lens'' from the getter and setter.
101 | lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
102 | lens getter setter = \f s -> setter s <$> f (getter s)
103 | {-# INLINE lens #-}
104 | 


--------------------------------------------------------------------------------
/co-log-core.cabal:
--------------------------------------------------------------------------------
  1 | cabal-version:       2.4
  2 | name:                co-log-core
  3 | version:             0.3.2.5
  4 | synopsis:            Composable Contravariant Comonadic Logging Library
  5 | description:
  6 |     This package provides core types and functions to work with the @LogAction@ data type which is both simple and powerful.
  7 |     .
  8 |     @
  9 |     __newtype__ LogAction m msg = LogAction
 10 |     \    { unLogAction :: msg -> m ()
 11 |     \    }
 12 |     @
 13 |     .
 14 |     The ideas behind this package are described in the following blog post:
 15 |     .
 16 |     * [co-log: Composable Contravariant Combinatorial Comonadic Configurable Convenient Logging](https://kowainik.github.io/posts/2018-09-25-co-log)
 17 |     .
 18 |     See the following packages for different implementations based on @co-log-core@:
 19 |     .
 20 |     * [co-log](http://hackage.haskell.org/package/co-log): taggless final implementations.
 21 |     * [co-log-polysemy](http://hackage.haskell.org/package/co-log-polysemy): extensible
 22 |       effects implementation based on @polysemy@.
 23 | 
 24 | homepage:            https://github.com/co-log/co-log-core
 25 | bug-reports:         https://github.com/co-log/co-log-core/issues
 26 | license:             MPL-2.0
 27 | license-file:        LICENSE
 28 | author:              Dmitrii Kovanikov
 29 | maintainer:          Co-Log <xrom.xkov@gmail.com>
 30 | copyright:           2018-2020 Kowainik, 2021-2025 Co-Log
 31 | category:            Logging, Contravariant, Comonad
 32 | build-type:          Simple
 33 | stability:           stable
 34 | extra-doc-files:     CHANGELOG.md
 35 |                      README.md
 36 | tested-with:         GHC == 8.2.2
 37 |                      GHC == 8.4.4
 38 |                      GHC == 8.6.5
 39 |                      GHC == 8.8.4
 40 |                      GHC == 8.10.7
 41 |                      GHC == 9.0.2
 42 |                      GHC == 9.2.8
 43 |                      GHC == 9.4.8
 44 |                      GHC == 9.6.6
 45 |                      GHC == 9.8.4
 46 |                      GHC == 9.10.1
 47 |                      GHC == 9.12.1
 48 | 
 49 | source-repository head
 50 |   type:                git
 51 |   location:            https://github.com/co-log/co-log-core.git
 52 | 
 53 | common common-options
 54 |   build-depends:       base >= 4.10.1.0 && < 4.22
 55 | 
 56 |   ghc-options:         -Wall
 57 |                        -Wcompat
 58 |                        -Widentities
 59 |                        -Wincomplete-uni-patterns
 60 |                        -Wincomplete-record-updates
 61 |                        -Wredundant-constraints
 62 |   if impl(ghc >= 8.2)
 63 |     ghc-options:       -fhide-source-paths
 64 |   if impl(ghc >= 8.4)
 65 |     ghc-options:       -Wmissing-export-lists
 66 |                        -Wpartial-fields
 67 |   if impl(ghc >= 8.8)
 68 |     ghc-options:       -Wmissing-deriving-strategies
 69 |   if impl(ghc >= 8.10)
 70 |     ghc-options:       -Wunused-packages
 71 |   if impl(ghc >= 9.0)
 72 |     ghc-options:       -Winvalid-haddock
 73 |   if impl(ghc >= 9.2)
 74 |     ghc-options:       -Wredundant-bang-patterns
 75 |                        -Woperator-whitespace
 76 |   if impl(ghc >= 9.4)
 77 |     ghc-options:       -Wredundant-strictness-flags
 78 |                        -Wforall-identifier
 79 | 
 80 |   default-language:    Haskell2010
 81 |   default-extensions:  ConstraintKinds
 82 |                        DeriveFunctor
 83 |                        DeriveTraversable
 84 |                        DeriveGeneric
 85 |                        DerivingStrategies
 86 |                        GeneralizedNewtypeDeriving
 87 |                        InstanceSigs
 88 |                        LambdaCase
 89 |                        OverloadedStrings
 90 |                        RecordWildCards
 91 |                        ScopedTypeVariables
 92 |                        StandaloneDeriving
 93 |                        TupleSections
 94 |                        TypeApplications
 95 |                        ViewPatterns
 96 | 
 97 | library
 98 |   import:              common-options
 99 |   hs-source-dirs:      src
100 |   exposed-modules:     Colog.Core
101 |                        Colog.Core.Action
102 |                        Colog.Core.Class
103 |                        Colog.Core.Severity
104 |                        Colog.Core.IO
105 | 
106 | test-suite doctest
107 |   import:               common-options
108 |   type:                 exitcode-stdio-1.0
109 |   hs-source-dirs:       test
110 |   main-is:              Doctests.hs
111 |   build-depends:        doctest >= 0.16.0 && < 0.25
112 |                       , Glob ^>= 0.10.0
113 | 


--------------------------------------------------------------------------------
/src/Colog/Core/Severity.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE PatternSynonyms #-}
  2 | 
  3 | {- |
  4 | Module                  : Colog.Core.Severity
  5 | Copyright               : (c) 2018-2020 Kowainik, 2021-2025 Co-Log
  6 | SPDX-License-Identifier : MPL-2.0
  7 | Maintainer              : Co-Log <xrom.xkov@gmail.com>
  8 | Stability               : Stable
  9 | Portability             : Portable
 10 | 
 11 | This module introduces 'Severity' data type for expressing how severe the
 12 | message is. Also, it contains useful functions and patterns for work with 'Severity'.
 13 | 
 14 | 
 15 |  +-----------+---------+-----------------------------------------+-----------------------------+
 16 |  | Severity  | Pattern | Meaning                                 | Example                     |
 17 |  +===========+=========+=========================================+=============================+
 18 |  | 'Debug'   | 'D'     | Information useful for debug purposes   | Internal function call logs |
 19 |  +-----------+---------+-----------------------------------------+-----------------------------+
 20 |  | 'Info'    | 'I'     | Normal operational information          | Finish file uploading       |
 21 |  +-----------+---------+-----------------------------------------+-----------------------------+
 22 |  | 'Warning' | 'W'     | General warnings, non-critical failures | Image load error            |
 23 |  +-----------+---------+-----------------------------------------+-----------------------------+
 24 |  | 'Error'   | 'E'     | General errors/severe errors            | Could not connect to the DB |
 25 |  +-----------+---------+-----------------------------------------+-----------------------------+
 26 | -}
 27 | 
 28 | module Colog.Core.Severity
 29 |        ( Severity (..)
 30 |          -- ** Patterns
 31 |          -- $pattern
 32 |        , pattern D
 33 |        , pattern I
 34 |        , pattern W
 35 |        , pattern E
 36 |        , filterBySeverity
 37 |        , WithSeverity (..)
 38 |        , mapSeverity
 39 |        ) where
 40 | 
 41 | import Data.Ix (Ix)
 42 | 
 43 | import Colog.Core.Action (LogAction (..), cfilter)
 44 | 
 45 | 
 46 | -- | Severity for the log messages.
 47 | data Severity
 48 |     {- | Information useful for debug purposes.
 49 | 
 50 |     E.g. output of the function that is important for the internal development,
 51 |     not for users. Like, the result of SQL query.
 52 |     -}
 53 |     = Debug
 54 |     {- | Normal operational information.
 55 | 
 56 |     E.g. describing general steps: starting application, finished downloading.
 57 |     -}
 58 |     | Info
 59 |     {- | General warnings, non-critical failures.
 60 | 
 61 |     E.g. couldn't download icon from some service to display.
 62 |     -}
 63 |     | Warning
 64 |     {- | General errors/severe errors.
 65 | 
 66 |     E.g. exceptional situations: couldn't syncronize accounts.
 67 |     -}
 68 |     | Error
 69 |     deriving stock (Show, Read, Eq, Ord, Enum, Bounded, Ix)
 70 | 
 71 | {- $pattern
 72 | Instead of using full names of the constructors you can instead use one-letter
 73 | patterns. To do so you can import and use the pattern:
 74 | 
 75 | @
 76 | __import__ Colog (__pattern__ D)
 77 | 
 78 | example :: WithLog env Message m => m ()
 79 | example = log D "I'm using severity pattern"
 80 | @
 81 | 
 82 | Moreover, you could use patterns when pattern-matching on severity
 83 | 
 84 | @
 85 | errorToStderr :: 'Severity' -> IO ()
 86 | errorToStderr E = hputStrLn stderr "Error severity"
 87 | errorToStderr _ = putStrLn "Something else"
 88 | @
 89 | -}
 90 | 
 91 | pattern D, I, W, E :: Severity
 92 | pattern D <- Debug   where D = Debug
 93 | pattern I <- Info    where I = Info
 94 | pattern W <- Warning where W = Warning
 95 | pattern E <- Error   where E = Error
 96 | {-# COMPLETE D, I, W, E #-}
 97 | 
 98 | -- | Filters messages by the given 'Severity'.
 99 | filterBySeverity
100 |     :: Applicative m
101 |     => Severity
102 |     -> (a -> Severity)
103 |     -> LogAction m a
104 |     -> LogAction m a
105 | filterBySeverity s fs = cfilter (\a -> fs a >= s)
106 | {-# INLINE filterBySeverity #-}
107 | 
108 | -- Note: the order of the fields here is to allow the constructor to be used infix.
109 | {-| A message tagged with a 'Severity'.
110 |  
111 | It is common to want to log various types of messages tagged with a severity. 
112 | 'WithSeverity' provides a standard way to do so while allowing the messages to be processed independently of the severity.
113 | 
114 | It is easy to 'cmap' over a 'LogAction m (WithSeverity a)', or to filter based on the severity.
115 | 
116 | @
117 | logSomething :: 'LogAction' m ('WithSeverity' 'String') -> m ()
118 | logSomething logger = logger <& "hello" \`WithSeverity\` 'Info'
119 | 
120 | cmap' :: (b -> a) -> 'LogAction' m ('WithSeverity' a) -> 'LogAction' m ('WithSeverity' b)
121 | cmap' f action = 'cmap' ('fmap' f) action
122 | 
123 | filterBySeverity' :: ('Applicative' m) => 'Severity' -> 'LogAction' m ('WithSeverity' a) -> 'LogAction' m ('WithSeverity' a)
124 | filterBySeverity' threshold action = 'filterBySeverity' threshold 'getSeverity' action
125 | @
126 | 
127 | @since 0.3.1.0
128 | -}
129 | data WithSeverity msg = WithSeverity { getMsg :: msg , getSeverity :: Severity }
130 |   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable)
131 | 
132 | {- | Map the given function over the severity of a 'WithSeverity'.
133 |  
134 | This can be useful to operate generically over the severity, for example:
135 | 
136 | @
137 | suppressErrors :: 'LogAction' m ('WithSeverity' msg) -> 'LogAction' m ('WithSeverity' msg)
138 | suppressErrors = 'cmap' ('mapSeverity' (\s -> if s == 'Error' then 'Warning' else s))
139 | @
140 | 
141 | @since 0.3.1.0
142 | -}
143 | mapSeverity :: (Severity -> Severity) -> WithSeverity msg -> WithSeverity msg
144 | mapSeverity f (WithSeverity msg sev) = WithSeverity msg (f sev)
145 | {-# INLINE mapSeverity #-}
146 | 


--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
  1 | # Change log
  2 | 
  3 | `co-log-core` uses [PVP Versioning][1].
  4 | The change log is available [on GitHub][2].
  5 | 
  6 | ## 0.3.2.5 — March 2, 2025
  7 | 
  8 | ## What's Changed
  9 | 
 10 | * Allow `doctest-0.24`.
 11 | 
 12 | **Full Changelog**: https://github.com/co-log/co-log-core/compare/v0.3.2.4...v0.3.2.5
 13 | 
 14 | ## 0.3.2.4 — January 5, 2025
 15 | 
 16 | ## What's Changed
 17 | 
 18 | * Support ghc-9.12.
 19 | 
 20 | **Full Changelog**: https://github.com/co-log/co-log-core/compare/v0.3.2.3...v0.3.2.4
 21 | 
 22 | ## 0.3.2.3 — December 15, 2024
 23 | 
 24 | ## What's Changed
 25 | 
 26 | * Allow `doctest-0.23`.
 27 | 
 28 | **Full Changelog**: https://github.com/co-log/co-log-core/compare/v0.3.2.2...v0.3.2.3
 29 | 
 30 | ## 0.3.2.2 — May 21, 2024
 31 | 
 32 | ## What's Changed
 33 | * GA(deps): Bump actions/cache from 3 to 4 by @dependabot in https://github.com/co-log/co-log-core/pull/40
 34 | * Support ghc-9.10. by @alaendle in https://github.com/co-log/co-log-core/pull/41
 35 | 
 36 | 
 37 | **Full Changelog**: https://github.com/co-log/co-log-core/compare/v0.3.2.1...v0.3.2.2
 38 | 
 39 | ## 0.3.2.1 — Oct 20, 2023
 40 | 
 41 | ## What's Changed
 42 | * Relax doctest boundaries. by @alaendle in [#32](https://github.com/co-log/co-log-core/pull/32)
 43 | * GA(deps): Bump actions/checkout from 3 to 4 by @dependabot in [#35](https://github.com/co-log/co-log-core/pull/35)
 44 | * Allow doctest-0.22 by @Vekhir in [#36](https://github.com/co-log/co-log-core/pull/36)
 45 | * [#29] Support GHC 9.6 by @vrom911 in [#33](https://github.com/co-log/co-log-core/pull/33)
 46 | * Support ghc-9.8 by @alaendle in [#37](https://github.com/co-log/co-log-core/pull/37)
 47 | * Publish to hackage directly from GitHub by @alaendle in [#38](https://github.com/co-log/co-log-core/pull/38)
 48 | 
 49 | ## New Contributors
 50 | * @Vekhir made their first contribution in https://github.com/co-log/co-log-core/pull/36
 51 | 
 52 | **Full Changelog**: https://github.com/co-log/co-log-core/compare/v0.3.2.0...v0.3.2.1
 53 | 
 54 | ## 0.3.2.0 — Nov 2, 2022
 55 | 
 56 | - [#25](https://github.com/co-log/co-log-core/issues/25):
 57 |   Support GHC-9.4.
 58 | 
 59 | ## 0.3.1.0 — Feb 15, 2022
 60 | 
 61 | - [#7](https://github.com/co-log/co-log-core/issues/7):
 62 |   Support GHC-9.2.
 63 | - [#13](https://github.com/co-log/co-log-core/issues/13):
 64 |   Add `WithSeverity` and `mapSeverity` to `Colog.Severity`.
 65 | 
 66 | ## 🎃 0.3.0.0 — Oct 29, 2021
 67 | 
 68 | - [#223](https://github.com/co-log/co-log/pull/223):
 69 |   Support GHC-9.0.1.
 70 | - [#176](https://github.com/co-log/co-log/issues/176):
 71 |   Add `logFlush` action to flush the given `Handle`.
 72 | 
 73 |   **Breaking change:** All `withLog*File` functions how flush handle
 74 |   after logging each message. Now you'll see logs in the file
 75 |   immediately.
 76 | 
 77 |   **Migration guide:** If you rely on the previous behaviour, then
 78 |   copy-paste corresponding functions and remove flushing.
 79 | 
 80 | - Update maintainers information to the new
 81 |   [Co-Log](https://github.com/co-log) organization.
 82 | 
 83 | ## 0.2.1.1 — Apr 18, 2020
 84 | 
 85 | - [#186](https://github.com/co-log/co-log/issues/186):
 86 |   Support GHC-8.10.1.
 87 | 
 88 | ## 0.2.1.0 — Jan 19, 2020
 89 | 
 90 | - [#139](https://github.com/co-log/co-log/issues/139):
 91 |   Add (unrepresentable) `Functor` instance for `LogAction` with the
 92 |   custom type-error.
 93 |   (by [@vrom911](https://github.com/vrom911))
 94 | - [#148](https://github.com/co-log/co-log/issues/148):
 95 |   Support GHC-8.8.2.
 96 |   (by [@chshersh](https://github.com/chshersh))
 97 | - [#122](https://github.com/co-log/co-log/issues/122):
 98 |   Add the `separate` combinator.
 99 |   (by [@vrom911](https://github.com/vrom911))
100 | - [#125](https://github.com/co-log/co-log/issues/125):
101 |   Add monadic versions of contravariant functions.
102 |   (by [@piq9117](https://github.com/piq9117))
103 | - [#138](https://github.com/co-log/co-log/issues/138):
104 |   Add `hoistLogAction` — higher-order transformation function.
105 |   (by [@jiribenes](https://github.com/jiribenes))
106 | - [#123](https://github.com/co-log/co-log/issues/123):
107 |   Write default implementation to `getLogAction` via `logActionL`.
108 |   (by [@SanchayanMaity](https://github.com/SanchayanMaity))
109 | 
110 | ## 0.2.0.0 — May 5, 2019
111 | 
112 | - [#85](https://github.com/co-log/co-log/issues/85):
113 |   Move `overLogAction` to `HasLog` typeclass
114 | - [#101](https://github.com/co-log/co-log/issues/101):
115 |   Add `logActionL` lens with default implementation to `HasLog` type class.
116 | - [#99](https://github.com/co-log/co-log/issues/99):
117 |   Add comonadic combinators: `duplicate` and `multiplicate`.
118 | - [#78](https://github.com/co-log/co-log/issues/78):
119 |   Improve documentation significantly.
120 | 
121 | ## 0.1.1 — Nov 15, 2018
122 | 
123 | - [#63](https://github.com/co-log/co-log/issues/63):
124 |   Add `logPrint`, `logPrintStderr`, `logPrintHandle` and `withLogPrintFile` to `Colog.Core.IO`.
125 | - [#46](https://github.com/co-log/co-log/issues/46):
126 |   Moves `logStringStdout`, `logStringStderr`, `logStringHandle`,
127 |   `withLogStringFile` from `Colog.Actions` to `Colog.Core.IO`.
128 | - [#48](https://github.com/co-log/co-log/issues/48):
129 |   Adds `liftLogIO` function.
130 | - [#49](https://github.com/co-log/co-log/issues/49):
131 |   Add `<&` and `&>`operators for `unLogAction`.
132 | - [#47](https://github.com/co-log/co-log/issues/47):
133 |   Add `doctest` tests.
134 | - [#13](https://github.com/co-log/co-log/issues/13):
135 |   Add `.cabal` file description and improve documentation.
136 | - [#39](https://github.com/co-log/co-log/issues/39):
137 |   Support GHC-8.2.2 and GHC-8.6.2.
138 | 
139 | ## 0.1.0
140 | 
141 | - [#38](https://github.com/co-log/co-log/issues/38):
142 |   Rename `cbind` to `cmapM`.
143 | 
144 | - [#37](https://github.com/co-log/co-log/issues/37):
145 |   Add `base` bounds.
146 | 
147 | ## 0.0.0
148 | 
149 | - Initially created.
150 | 
151 | [1]: https://pvp.haskell.org
152 | [2]: https://github.com/co-log/co-log-core/releases
153 | 


--------------------------------------------------------------------------------
/src/Colog/Core/IO.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | 
  3 | {- |
  4 | Module                  : Colog.Core.IO
  5 | Copyright               : (c) 2018-2020 Kowainik, 2021-2025 Co-Log
  6 | SPDX-License-Identifier : MPL-2.0
  7 | Maintainer              : Co-Log <xrom.xkov@gmail.com>
  8 | Stability               : Stable
  9 | Portability             : Portable
 10 | 
 11 | Introduces logging actions working in 'MonadIO'. These actions are very basic
 12 | and inefficient because they use the 'String' data type. If you don't want to
 13 | have extra dependencies and performance of logging is not the bottleneck of your
 14 | application, then these functions should be enough. Otherwise use functions from
 15 | the "Colog.Actions" module from the @co-log@ package.
 16 | -}
 17 | 
 18 | module Colog.Core.IO
 19 |        ( -- * 'String' actions
 20 |          logStringStdout
 21 |        , logStringStderr
 22 |        , logStringHandle
 23 |        , withLogStringFile
 24 | 
 25 |          -- * 'Show' actions
 26 |        , logPrint
 27 |        , logPrintStderr
 28 |        , logPrintHandle
 29 |        , withLogPrintFile
 30 | 
 31 |          -- * Various combinators
 32 |        , liftLogIO
 33 |        , logFlush
 34 |        ) where
 35 | 
 36 | import Colog.Core.Action      (LogAction (..))
 37 | import Control.Monad.IO.Class (MonadIO, liftIO)
 38 | import Data.Semigroup         ((<>))
 39 | import System.IO              (Handle, IOMode (AppendMode), hFlush, hPrint,
 40 |                                hPutStrLn, stderr, withFile)
 41 | 
 42 | 
 43 | {- $setup
 44 | >>> import Colog.Core.Action
 45 | -}
 46 | 
 47 | ----------------------------------------------------------------------------
 48 | -- String
 49 | ----------------------------------------------------------------------------
 50 | 
 51 | {- | Action that prints 'String' to stdout.
 52 | This action does not flush the output buffer.
 53 | If buffering mode is block buffering, the effect of this action can be delayed.
 54 | 
 55 | >>> logStringStdout <& "foo"
 56 | foo
 57 | -}
 58 | logStringStdout :: MonadIO m => LogAction m String
 59 | logStringStdout = LogAction (liftIO . putStrLn)
 60 | {-# INLINE logStringStdout #-}
 61 | {-# SPECIALIZE logStringStdout :: LogAction IO String #-}
 62 | 
 63 | {- | Action that prints 'String' to stderr.
 64 | This action does not flush the output buffer.
 65 | If buffering mode is block buffering, the effect of this action can be delayed.
 66 | 
 67 | >>> logStringStderr <& "foo"
 68 | foo
 69 | -}
 70 | logStringStderr :: MonadIO m => LogAction m String
 71 | logStringStderr = logStringHandle stderr
 72 | {-# INLINE logStringStderr #-}
 73 | {-# SPECIALIZE logStringStderr :: LogAction IO String #-}
 74 | 
 75 | {- | Action that prints 'String' to 'Handle'.
 76 | This action does not flush the output buffer.
 77 | If buffering mode is block buffering, the effect of this action can be delayed.
 78 | 
 79 | >>> logStringHandle stderr <& "foo"
 80 | foo
 81 | -}
 82 | logStringHandle :: MonadIO m => Handle -> LogAction m String
 83 | logStringHandle handle = LogAction $ liftIO . hPutStrLn handle
 84 | {-# INLINE logStringHandle #-}
 85 | {-# SPECIALIZE logStringHandle :: Handle -> LogAction IO String #-}
 86 | 
 87 | {- | Action that prints 'String' to file. Instead of returning 'LogAction' it's
 88 | implemented in continuation-passing style because it's more efficient to open
 89 | file only once at the start of the application and write to 'Handle' instead of
 90 | opening file each time we need to write to it.
 91 | 
 92 | Opens file in 'AppendMode'. Automatically flushes the output buffer.
 93 | 
 94 | #ifndef mingw32_HOST_OS
 95 | 
 96 | >>> logger action = action <& "foo"
 97 | >>> withLogStringFile "/dev/stdout" logger
 98 | foo
 99 | 
100 | #endif
101 | -}
102 | withLogStringFile :: MonadIO m => FilePath -> (LogAction m String -> IO r) -> IO r
103 | withLogStringFile path action = withFile path AppendMode $ \handle ->
104 |   action (logStringHandle handle <> logFlush handle)
105 | {-# INLINE withLogStringFile #-}
106 | {-# SPECIALIZE withLogStringFile :: FilePath -> (LogAction IO String -> IO r) -> IO r #-}
107 | 
108 | ----------------------------------------------------------------------------
109 | -- Show
110 | ----------------------------------------------------------------------------
111 | 
112 | {- | Action that prints to stdout using 'Show'.
113 | This action does not flush the output buffer.
114 | If buffering mode is block buffering, the effect of this action can be delayed.
115 | 
116 | >>> logPrint <& 5
117 | 5
118 | -}
119 | logPrint :: forall a m . (Show a, MonadIO m) => LogAction m a
120 | logPrint = LogAction $ liftIO . print
121 | {-# INLINE logPrint #-}
122 | {-# SPECIALIZE logPrint :: Show a => LogAction IO a #-}
123 | 
124 | {- | Action that prints to stderr using 'Show'.
125 | This action does not flush the output buffer.
126 | If buffering mode is block buffering, the effect of this action can be delayed.
127 | 
128 | >>> logPrintStderr <& 5
129 | 5
130 | -}
131 | logPrintStderr :: forall a m . (Show a, MonadIO m) => LogAction m a
132 | logPrintStderr = logPrintHandle stderr
133 | {-# INLINE logPrintStderr #-}
134 | {-# SPECIALIZE logPrintStderr :: Show a => LogAction IO a #-}
135 | 
136 | {- | Action that prints to a 'Handle' using 'Show'.
137 | This action does not flush the output buffer.
138 | If buffering mode is block buffering, the effect of this action can be delayed.
139 | 
140 | >>> logPrintHandle stderr <& 5
141 | 5
142 | -}
143 | logPrintHandle :: forall a m . (Show a, MonadIO m) => Handle -> LogAction m a
144 | logPrintHandle handle = LogAction $ liftIO . hPrint handle
145 | {-# INLINE logPrintHandle #-}
146 | {-# SPECIALIZE logPrintHandle :: Show a => Handle -> LogAction IO a #-}
147 | 
148 | {- | Action that prints to a file using 'Show'. See 'withLogStringFile' for details.
149 | -}
150 | withLogPrintFile
151 |     :: forall a m r . (Show a, MonadIO m)
152 |     => FilePath
153 |     -> (LogAction m a -> IO r)
154 |     -> IO r
155 | withLogPrintFile path action = withFile path AppendMode $ \handle ->
156 |   action (logPrintHandle handle <> logFlush handle)
157 | {-# INLINE withLogPrintFile #-}
158 | {-# SPECIALIZE withLogPrintFile :: Show a => FilePath -> (LogAction IO a -> IO r) -> IO r #-}
159 | 
160 | ----------------------------------------------------------------------------
161 | -- Misc
162 | ----------------------------------------------------------------------------
163 | 
164 | {- | Lifts a LogAction over IO into a more general Monad.
165 | 
166 | >>> logToStdout = LogAction putStrLn
167 | >>> liftLogIO logToStdout <& "foo"
168 | foo
169 | -}
170 | liftLogIO :: MonadIO m => LogAction IO msg -> LogAction m msg
171 | liftLogIO (LogAction action) = LogAction (liftIO . action)
172 | {-# INLINE liftLogIO #-}
173 | 
174 | {- | This action can be used in combination with other actions to flush
175 | a handle every time you log anything.
176 | 
177 | @since 0.3.0.0
178 | -}
179 | logFlush :: MonadIO m => Handle -> LogAction m a
180 | logFlush handle = LogAction $ const $ liftIO $ hFlush handle
181 | {-# INLINE logFlush #-}
182 | {-# SPECIALIZE logFlush :: Handle -> LogAction IO a #-}
183 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
  1 | Mozilla Public License Version 2.0
  2 | ==================================
  3 | 
  4 | 1. Definitions
  5 | --------------
  6 | 
  7 | 1.1. "Contributor"
  8 |     means each individual or legal entity that creates, contributes to
  9 |     the creation of, or owns Covered Software.
 10 | 
 11 | 1.2. "Contributor Version"
 12 |     means the combination of the Contributions of others (if any) used
 13 |     by a Contributor and that particular Contributor's Contribution.
 14 | 
 15 | 1.3. "Contribution"
 16 |     means Covered Software of a particular Contributor.
 17 | 
 18 | 1.4. "Covered Software"
 19 |     means Source Code Form to which the initial Contributor has attached
 20 |     the notice in Exhibit A, the Executable Form of such Source Code
 21 |     Form, and Modifications of such Source Code Form, in each case
 22 |     including portions thereof.
 23 | 
 24 | 1.5. "Incompatible With Secondary Licenses"
 25 |     means
 26 | 
 27 |     (a) that the initial Contributor has attached the notice described
 28 |         in Exhibit B to the Covered Software; or
 29 | 
 30 |     (b) that the Covered Software was made available under the terms of
 31 |         version 1.1 or earlier of the License, but not also under the
 32 |         terms of a Secondary License.
 33 | 
 34 | 1.6. "Executable Form"
 35 |     means any form of the work other than Source Code Form.
 36 | 
 37 | 1.7. "Larger Work"
 38 |     means a work that combines Covered Software with other material, in
 39 |     a separate file or files, that is not Covered Software.
 40 | 
 41 | 1.8. "License"
 42 |     means this document.
 43 | 
 44 | 1.9. "Licensable"
 45 |     means having the right to grant, to the maximum extent possible,
 46 |     whether at the time of the initial grant or subsequently, any and
 47 |     all of the rights conveyed by this License.
 48 | 
 49 | 1.10. "Modifications"
 50 |     means any of the following:
 51 | 
 52 |     (a) any file in Source Code Form that results from an addition to,
 53 |         deletion from, or modification of the contents of Covered
 54 |         Software; or
 55 | 
 56 |     (b) any new file in Source Code Form that contains any Covered
 57 |         Software.
 58 | 
 59 | 1.11. "Patent Claims" of a Contributor
 60 |     means any patent claim(s), including without limitation, method,
 61 |     process, and apparatus claims, in any patent Licensable by such
 62 |     Contributor that would be infringed, but for the grant of the
 63 |     License, by the making, using, selling, offering for sale, having
 64 |     made, import, or transfer of either its Contributions or its
 65 |     Contributor Version.
 66 | 
 67 | 1.12. "Secondary License"
 68 |     means either the GNU General Public License, Version 2.0, the GNU
 69 |     Lesser General Public License, Version 2.1, the GNU Affero General
 70 |     Public License, Version 3.0, or any later versions of those
 71 |     licenses.
 72 | 
 73 | 1.13. "Source Code Form"
 74 |     means the form of the work preferred for making modifications.
 75 | 
 76 | 1.14. "You" (or "Your")
 77 |     means an individual or a legal entity exercising rights under this
 78 |     License. For legal entities, "You" includes any entity that
 79 |     controls, is controlled by, or is under common control with You. For
 80 |     purposes of this definition, "control" means (a) the power, direct
 81 |     or indirect, to cause the direction or management of such entity,
 82 |     whether by contract or otherwise, or (b) ownership of more than
 83 |     fifty percent (50%) of the outstanding shares or beneficial
 84 |     ownership of such entity.
 85 | 
 86 | 2. License Grants and Conditions
 87 | --------------------------------
 88 | 
 89 | 2.1. Grants
 90 | 
 91 | Each Contributor hereby grants You a world-wide, royalty-free,
 92 | non-exclusive license:
 93 | 
 94 | (a) under intellectual property rights (other than patent or trademark)
 95 |     Licensable by such Contributor to use, reproduce, make available,
 96 |     modify, display, perform, distribute, and otherwise exploit its
 97 |     Contributions, either on an unmodified basis, with Modifications, or
 98 |     as part of a Larger Work; and
 99 | 
100 | (b) under Patent Claims of such Contributor to make, use, sell, offer
101 |     for sale, have made, import, and otherwise transfer either its
102 |     Contributions or its Contributor Version.
103 | 
104 | 2.2. Effective Date
105 | 
106 | The licenses granted in Section 2.1 with respect to any Contribution
107 | become effective for each Contribution on the date the Contributor first
108 | distributes such Contribution.
109 | 
110 | 2.3. Limitations on Grant Scope
111 | 
112 | The licenses granted in this Section 2 are the only rights granted under
113 | this License. No additional rights or licenses will be implied from the
114 | distribution or licensing of Covered Software under this License.
115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a
116 | Contributor:
117 | 
118 | (a) for any code that a Contributor has removed from Covered Software;
119 |     or
120 | 
121 | (b) for infringements caused by: (i) Your and any other third party's
122 |     modifications of Covered Software, or (ii) the combination of its
123 |     Contributions with other software (except as part of its Contributor
124 |     Version); or
125 | 
126 | (c) under Patent Claims infringed by Covered Software in the absence of
127 |     its Contributions.
128 | 
129 | This License does not grant any rights in the trademarks, service marks,
130 | or logos of any Contributor (except as may be necessary to comply with
131 | the notice requirements in Section 3.4).
132 | 
133 | 2.4. Subsequent Licenses
134 | 
135 | No Contributor makes additional grants as a result of Your choice to
136 | distribute the Covered Software under a subsequent version of this
137 | License (see Section 10.2) or under the terms of a Secondary License (if
138 | permitted under the terms of Section 3.3).
139 | 
140 | 2.5. Representation
141 | 
142 | Each Contributor represents that the Contributor believes its
143 | Contributions are its original creation(s) or it has sufficient rights
144 | to grant the rights to its Contributions conveyed by this License.
145 | 
146 | 2.6. Fair Use
147 | 
148 | This License is not intended to limit any rights You have under
149 | applicable copyright doctrines of fair use, fair dealing, or other
150 | equivalents.
151 | 
152 | 2.7. Conditions
153 | 
154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
155 | in Section 2.1.
156 | 
157 | 3. Responsibilities
158 | -------------------
159 | 
160 | 3.1. Distribution of Source Form
161 | 
162 | All distribution of Covered Software in Source Code Form, including any
163 | Modifications that You create or to which You contribute, must be under
164 | the terms of this License. You must inform recipients that the Source
165 | Code Form of the Covered Software is governed by the terms of this
166 | License, and how they can obtain a copy of this License. You may not
167 | attempt to alter or restrict the recipients' rights in the Source Code
168 | Form.
169 | 
170 | 3.2. Distribution of Executable Form
171 | 
172 | If You distribute Covered Software in Executable Form then:
173 | 
174 | (a) such Covered Software must also be made available in Source Code
175 |     Form, as described in Section 3.1, and You must inform recipients of
176 |     the Executable Form how they can obtain a copy of such Source Code
177 |     Form by reasonable means in a timely manner, at a charge no more
178 |     than the cost of distribution to the recipient; and
179 | 
180 | (b) You may distribute such Executable Form under the terms of this
181 |     License, or sublicense it under different terms, provided that the
182 |     license for the Executable Form does not attempt to limit or alter
183 |     the recipients' rights in the Source Code Form under this License.
184 | 
185 | 3.3. Distribution of a Larger Work
186 | 
187 | You may create and distribute a Larger Work under terms of Your choice,
188 | provided that You also comply with the requirements of this License for
189 | the Covered Software. If the Larger Work is a combination of Covered
190 | Software with a work governed by one or more Secondary Licenses, and the
191 | Covered Software is not Incompatible With Secondary Licenses, this
192 | License permits You to additionally distribute such Covered Software
193 | under the terms of such Secondary License(s), so that the recipient of
194 | the Larger Work may, at their option, further distribute the Covered
195 | Software under the terms of either this License or such Secondary
196 | License(s).
197 | 
198 | 3.4. Notices
199 | 
200 | You may not remove or alter the substance of any license notices
201 | (including copyright notices, patent notices, disclaimers of warranty,
202 | or limitations of liability) contained within the Source Code Form of
203 | the Covered Software, except that You may alter any license notices to
204 | the extent required to remedy known factual inaccuracies.
205 | 
206 | 3.5. Application of Additional Terms
207 | 
208 | You may choose to offer, and to charge a fee for, warranty, support,
209 | indemnity or liability obligations to one or more recipients of Covered
210 | Software. However, You may do so only on Your own behalf, and not on
211 | behalf of any Contributor. You must make it absolutely clear that any
212 | such warranty, support, indemnity, or liability obligation is offered by
213 | You alone, and You hereby agree to indemnify every Contributor for any
214 | liability incurred by such Contributor as a result of warranty, support,
215 | indemnity or liability terms You offer. You may include additional
216 | disclaimers of warranty and limitations of liability specific to any
217 | jurisdiction.
218 | 
219 | 4. Inability to Comply Due to Statute or Regulation
220 | ---------------------------------------------------
221 | 
222 | If it is impossible for You to comply with any of the terms of this
223 | License with respect to some or all of the Covered Software due to
224 | statute, judicial order, or regulation then You must: (a) comply with
225 | the terms of this License to the maximum extent possible; and (b)
226 | describe the limitations and the code they affect. Such description must
227 | be placed in a text file included with all distributions of the Covered
228 | Software under this License. Except to the extent prohibited by statute
229 | or regulation, such description must be sufficiently detailed for a
230 | recipient of ordinary skill to be able to understand it.
231 | 
232 | 5. Termination
233 | --------------
234 | 
235 | 5.1. The rights granted under this License will terminate automatically
236 | if You fail to comply with any of its terms. However, if You become
237 | compliant, then the rights granted under this License from a particular
238 | Contributor are reinstated (a) provisionally, unless and until such
239 | Contributor explicitly and finally terminates Your grants, and (b) on an
240 | ongoing basis, if such Contributor fails to notify You of the
241 | non-compliance by some reasonable means prior to 60 days after You have
242 | come back into compliance. Moreover, Your grants from a particular
243 | Contributor are reinstated on an ongoing basis if such Contributor
244 | notifies You of the non-compliance by some reasonable means, this is the
245 | first time You have received notice of non-compliance with this License
246 | from such Contributor, and You become compliant prior to 30 days after
247 | Your receipt of the notice.
248 | 
249 | 5.2. If You initiate litigation against any entity by asserting a patent
250 | infringement claim (excluding declaratory judgment actions,
251 | counter-claims, and cross-claims) alleging that a Contributor Version
252 | directly or indirectly infringes any patent, then the rights granted to
253 | You by any and all Contributors for the Covered Software under Section
254 | 2.1 of this License shall terminate.
255 | 
256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all
257 | end user license agreements (excluding distributors and resellers) which
258 | have been validly granted by You or Your distributors under this License
259 | prior to termination shall survive termination.
260 | 
261 | ************************************************************************
262 | *                                                                      *
263 | *  6. Disclaimer of Warranty                                           *
264 | *  -------------------------                                           *
265 | *                                                                      *
266 | *  Covered Software is provided under this License on an "as is"       *
267 | *  basis, without warranty of any kind, either expressed, implied, or  *
268 | *  statutory, including, without limitation, warranties that the       *
269 | *  Covered Software is free of defects, merchantable, fit for a        *
270 | *  particular purpose or non-infringing. The entire risk as to the     *
271 | *  quality and performance of the Covered Software is with You.        *
272 | *  Should any Covered Software prove defective in any respect, You     *
273 | *  (not any Contributor) assume the cost of any necessary servicing,   *
274 | *  repair, or correction. This disclaimer of warranty constitutes an   *
275 | *  essential part of this License. No use of any Covered Software is   *
276 | *  authorized under this License except under this disclaimer.         *
277 | *                                                                      *
278 | ************************************************************************
279 | 
280 | ************************************************************************
281 | *                                                                      *
282 | *  7. Limitation of Liability                                          *
283 | *  --------------------------                                          *
284 | *                                                                      *
285 | *  Under no circumstances and under no legal theory, whether tort      *
286 | *  (including negligence), contract, or otherwise, shall any           *
287 | *  Contributor, or anyone who distributes Covered Software as          *
288 | *  permitted above, be liable to You for any direct, indirect,         *
289 | *  special, incidental, or consequential damages of any character      *
290 | *  including, without limitation, damages for lost profits, loss of    *
291 | *  goodwill, work stoppage, computer failure or malfunction, or any    *
292 | *  and all other commercial damages or losses, even if such party      *
293 | *  shall have been informed of the possibility of such damages. This   *
294 | *  limitation of liability shall not apply to liability for death or   *
295 | *  personal injury resulting from such party's negligence to the       *
296 | *  extent applicable law prohibits such limitation. Some               *
297 | *  jurisdictions do not allow the exclusion or limitation of           *
298 | *  incidental or consequential damages, so this exclusion and          *
299 | *  limitation may not apply to You.                                    *
300 | *                                                                      *
301 | ************************************************************************
302 | 
303 | 8. Litigation
304 | -------------
305 | 
306 | Any litigation relating to this License may be brought only in the
307 | courts of a jurisdiction where the defendant maintains its principal
308 | place of business and such litigation shall be governed by laws of that
309 | jurisdiction, without reference to its conflict-of-law provisions.
310 | Nothing in this Section shall prevent a party's ability to bring
311 | cross-claims or counter-claims.
312 | 
313 | 9. Miscellaneous
314 | ----------------
315 | 
316 | This License represents the complete agreement concerning the subject
317 | matter hereof. If any provision of this License is held to be
318 | unenforceable, such provision shall be reformed only to the extent
319 | necessary to make it enforceable. Any law or regulation which provides
320 | that the language of a contract shall be construed against the drafter
321 | shall not be used to construe this License against a Contributor.
322 | 
323 | 10. Versions of the License
324 | ---------------------------
325 | 
326 | 10.1. New Versions
327 | 
328 | Mozilla Foundation is the license steward. Except as provided in Section
329 | 10.3, no one other than the license steward has the right to modify or
330 | publish new versions of this License. Each version will be given a
331 | distinguishing version number.
332 | 
333 | 10.2. Effect of New Versions
334 | 
335 | You may distribute the Covered Software under the terms of the version
336 | of the License under which You originally received the Covered Software,
337 | or under the terms of any subsequent version published by the license
338 | steward.
339 | 
340 | 10.3. Modified Versions
341 | 
342 | If you create software not governed by this License, and you want to
343 | create a new license for such software, you may create and use a
344 | modified version of this License if you rename the license and remove
345 | any references to the name of the license steward (except to note that
346 | such modified license differs from this License).
347 | 
348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary
349 | Licenses
350 | 
351 | If You choose to distribute Source Code Form that is Incompatible With
352 | Secondary Licenses under the terms of this version of the License, the
353 | notice described in Exhibit B of this License must be attached.
354 | 
355 | Exhibit A - Source Code Form License Notice
356 | -------------------------------------------
357 | 
358 |   This Source Code Form is subject to the terms of the Mozilla Public
359 |   License, v. 2.0. If a copy of the MPL was not distributed with this
360 |   file, You can obtain one at http://mozilla.org/MPL/2.0/.
361 | 
362 | If it is not possible or desirable to put the notice in a particular
363 | file, then You may include the notice in a location (such as a LICENSE
364 | file in a relevant directory) where a recipient would be likely to look
365 | for such a notice.
366 | 
367 | You may add additional accurate notices of copyright ownership.
368 | 
369 | Exhibit B - "Incompatible With Secondary Licenses" Notice
370 | ---------------------------------------------------------
371 | 
372 |   This Source Code Form is "Incompatible With Secondary Licenses", as
373 |   defined by the Mozilla Public License, v. 2.0.
374 | 


--------------------------------------------------------------------------------
/src/Colog/Core/Action.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP                  #-}
  2 | {-# LANGUAGE DataKinds            #-}
  3 | {-# LANGUAGE Rank2Types           #-}
  4 | {-# LANGUAGE TypeFamilies         #-}
  5 | {-# LANGUAGE TypeOperators        #-}
  6 | {-# LANGUAGE UndecidableInstances #-}
  7 | 
  8 | {- |
  9 | Module                  : Colog.Core.Action
 10 | Copyright               : (c) 2018-2020 Kowainik, 2021-2025 Co-Log
 11 | SPDX-License-Identifier : MPL-2.0
 12 | Maintainer              : Co-Log <xrom.xkov@gmail.com>
 13 | Stability               : Stable
 14 | Portability             : Portable
 15 | 
 16 | Implements core data types and combinators for logging actions.
 17 | -}
 18 | 
 19 | module Colog.Core.Action
 20 |        ( -- * Core type and instances
 21 |          LogAction (..)
 22 |        , (<&)
 23 |        , (&>)
 24 | 
 25 |          -- * 'Semigroup' combinators
 26 |        , foldActions
 27 | 
 28 |          -- * Contravariant combinators
 29 |          -- $contravariant
 30 |        , cfilter
 31 |        , cfilterM
 32 |        , cmap
 33 |        , (>$<)
 34 |        , cmapMaybe
 35 |        , cmapMaybeM
 36 |        , (Colog.Core.Action.>$)
 37 |        , cmapM
 38 | 
 39 |          -- * Divisible combinators
 40 |          -- $divisible
 41 |        , divide
 42 |        , divideM
 43 |        , conquer
 44 |        , (>*<)
 45 |        , (>*)
 46 |        , (*<)
 47 | 
 48 |          -- * Decidable combinators
 49 |          -- $decidable
 50 |        , lose
 51 |        , choose
 52 |        , chooseM
 53 |        , (>|<)
 54 | 
 55 |          -- * Comonadic combinators
 56 |          -- $comonad
 57 |        , extract
 58 |        , extend
 59 |        , (=>>)
 60 |        , (<<=)
 61 |        , duplicate
 62 |        , multiplicate
 63 |        , separate
 64 | 
 65 |          -- * Higher-order combinators
 66 |        , hoistLogAction
 67 |        ) where
 68 | 
 69 | import           Control.Monad              (when, (<=<), (>=>))
 70 | import           Data.Coerce                (coerce)
 71 | import           Data.Foldable              (fold, for_, traverse_)
 72 | import           Data.Kind                  (Constraint)
 73 | import           Data.List.NonEmpty         (NonEmpty (..))
 74 | import           Data.Monoid                (Monoid (..))
 75 | import           Data.Semigroup             (Semigroup (..), stimesMonoid)
 76 | import           Data.Void                  (Void, absurd)
 77 | import           GHC.TypeLits               (ErrorMessage (..), TypeError)
 78 | 
 79 | #if MIN_VERSION_base(4,12,0)
 80 | import qualified Data.Functor.Contravariant as Contravariant
 81 | #endif
 82 | 
 83 | {- $setup
 84 | >>> import Colog.Core.IO
 85 | -}
 86 | 
 87 | ----------------------------------------------------------------------------
 88 | -- Core data type with instances
 89 | ----------------------------------------------------------------------------
 90 | 
 91 | {- | Polymorphic and very general logging action type.
 92 | 
 93 | * @__msg__@ type variables is an input for logger. It can be 'Text' or custom
 94 | logging messsage with different fields that you want to format in future.
 95 | 
 96 | * @__m__@ type variable is for monadic action inside which logging is happening. It
 97 | can be either 'IO' or some custom pure monad.
 98 | 
 99 | Key design point here is that 'LogAction' is:
100 | 
101 | * 'Semigroup'
102 | * 'Monoid'
103 | * 'Data.Functor.Contravariant.Contravariant'
104 | * 'Data.Functor.Contravariant.Divisible.Divisible'
105 | * 'Data.Functor.Contravariant.Divisible.Decidable'
106 | * 'Control.Comonad.Comonad'
107 | -}
108 | newtype LogAction m msg = LogAction
109 |     { unLogAction :: msg -> m ()
110 |     }
111 | 
112 | {- | This instance allows you to join multiple logging actions into single one.
113 | 
114 | For example, if you have two actions like these:
115 | 
116 | @
117 | logToStdout :: 'LogAction' IO String  -- outputs String to terminal
118 | logToFile   :: 'LogAction' IO String  -- appends String to some file
119 | @
120 | 
121 | You can create new 'LogAction' that perform both actions one after another using 'Semigroup':
122 | 
123 | @
124 | logToBoth :: 'LogAction' IO String  -- outputs String to both terminal and some file
125 | logToBoth = logToStdout <> logToFile
126 | @
127 | -}
128 | instance Applicative m => Semigroup (LogAction m a) where
129 |     (<>) :: LogAction m a -> LogAction m a -> LogAction m a
130 |     LogAction action1 <> LogAction action2 = LogAction $ \a -> action1 a *> action2 a
131 |     {-# INLINE (<>) #-}
132 | 
133 |     sconcat :: NonEmpty (LogAction m a) -> LogAction m a
134 |     sconcat = foldActions
135 |     {-# INLINE sconcat #-}
136 | 
137 |     stimes :: Integral b => b -> LogAction m a -> LogAction m a
138 |     stimes = stimesMonoid
139 |     {-# INLINE stimes #-}
140 | 
141 | instance Applicative m => Monoid (LogAction m a) where
142 |     mappend :: LogAction m a -> LogAction m a -> LogAction m a
143 |     mappend = (<>)
144 |     {-# INLINE mappend #-}
145 | 
146 |     mempty :: LogAction m a
147 |     mempty = LogAction $ \_ -> pure ()
148 |     {-# INLINE mempty #-}
149 | 
150 |     mconcat :: [LogAction m a] -> LogAction m a
151 |     mconcat = foldActions
152 |     {-# INLINE mconcat #-}
153 | 
154 | #if MIN_VERSION_base(4,12,0)
155 | instance Contravariant.Contravariant (LogAction m) where
156 |     contramap :: (a -> b) -> LogAction m b -> LogAction m a
157 |     contramap = cmap
158 |     {-# INLINE contramap #-}
159 | 
160 |     (>$) :: b -> LogAction m b -> LogAction m a
161 |     (>$) = (Colog.Core.Action.>$)
162 |     {-# INLINE (>$) #-}
163 | #endif
164 | 
165 | -- | For tracking usage of unrepresentable class instances of 'LogAction'.
166 | type family UnrepresentableClass :: Constraint
167 |   where
168 |     UnrepresentableClass = TypeError
169 |         ( 'Text "'LogAction' cannot have a 'Functor' instance by design."
170 |         ' :$$: 'Text "However, you've attempted to use this instance."
171 | #if MIN_VERSION_base(4,12,0)
172 |         ' :$$: 'Text ""
173 |         ' :$$: 'Text "Probably you meant 'Contravariant' class instance with the following methods:"
174 |         ' :$$: 'Text "  * contramap :: (a -> b) -> LogAction m b -> LogAction m a"
175 |         ' :$$: 'Text "  * (>$) :: b -> LogAction m b -> LogAction m a"
176 | #endif
177 |         )
178 | 
179 | {- | ⚠️__CAUTION__⚠️ This instance is for custom error display only.
180 | 
181 | 'LogAction' is not supposed to have 'Functor' instance by design.
182 | 
183 | In case it is used by mistake, the user  will see the following:
184 | 
185 | #if MIN_VERSION_base(4,12,0)
186 | 
187 | >>> fmap show logStringStdout
188 | ...
189 | ... 'LogAction' cannot have a 'Functor' instance by design.
190 |       However, you've attempted to use this instance.
191 | ...
192 |       Probably you meant 'Contravariant' class instance with the following methods:
193 |         * contramap :: (a -> b) -> LogAction m b -> LogAction m a
194 |         * (>$) :: b -> LogAction m b -> LogAction m a
195 | ...
196 | 
197 | 
198 | #else
199 | 
200 | >>> fmap show logStringStdout
201 | ...
202 | ... 'LogAction' cannot have a 'Functor' instance by design.
203 |       However, you've attempted to use this instance.
204 | ...
205 | 
206 | #endif
207 | 
208 | @since 0.2.1.0
209 | -}
210 | instance UnrepresentableClass => Functor (LogAction m) where
211 |     fmap :: (a -> b) -> LogAction m a -> LogAction m b
212 |     fmap _ _ = error "Unreachable Functor instance of LogAction"
213 | 
214 |     (<$) :: a -> LogAction m b -> LogAction m a
215 |     _ <$  _ = error "Unreachable Functor instance of LogAction"
216 | 
217 | 
218 | {- | Operator version of 'unLogAction'. Note that because of the types, something like:
219 | 
220 | @
221 | action <& msg1 <& msg2
222 | @
223 | 
224 | doesn't make sense. Instead you want:
225 | 
226 | @
227 | action <& msg1 \>\> action <& msg2
228 | @
229 | 
230 | In addition, because '<&' has higher precedence than the other operators in this
231 | module, the following:
232 | 
233 | @
234 | f >$< action <& msg
235 | @
236 | 
237 | is equivalent to:
238 | 
239 | @
240 | (f >$< action) <& msg
241 | @
242 | -}
243 | infix 5 <&
244 | (<&) :: LogAction m msg -> msg -> m ()
245 | (<&) = coerce
246 | {-# INLINE (<&) #-}
247 | 
248 | {- | A flipped version of '<&'.
249 | 
250 | It shares the same precedence as '<&', so make sure to surround lower precedence
251 | operators in parentheses:
252 | 
253 | @
254 | msg &> (f >$< action)
255 | @
256 | -}
257 | infix 5 &>
258 | (&>) :: msg -> LogAction m msg -> m ()
259 | (&>) = flip (<&)
260 | {-# INLINE (&>) #-}
261 | 
262 | {- | Joins some 'Foldable' of 'LogAction's into single 'LogAction' using
263 | 'Semigroup' instance for 'LogAction'. This is basically specialized version of
264 | 'Data.Foldable.fold' function.
265 | -}
266 | foldActions :: (Foldable t, Applicative m) => t (LogAction m a) -> LogAction m a
267 | foldActions actions = LogAction $ \a -> for_ actions $ \(LogAction action) -> action a
268 | {-# INLINE foldActions #-}
269 | {-# SPECIALIZE foldActions :: Applicative m => [LogAction m a]          -> LogAction m a #-}
270 | {-# SPECIALIZE foldActions :: Applicative m => NonEmpty (LogAction m a) -> LogAction m a #-}
271 | 
272 | ----------------------------------------------------------------------------
273 | -- Contravariant combinators
274 | ----------------------------------------------------------------------------
275 | 
276 | {- $contravariant
277 | 
278 | Combinators that implement interface in the spirit of the following typeclass:
279 | 
280 | @
281 | __class__ Contravariant f __where__
282 |     contramap :: (a -> b) -> f b -> f a
283 | @
284 | -}
285 | 
286 | {- | Takes predicate and performs given logging action only if predicate returns
287 | 'True' on input logging message.
288 | -}
289 | cfilter :: Applicative m => (msg -> Bool) -> LogAction m msg -> LogAction m msg
290 | cfilter predicate (LogAction action) = LogAction $ \a -> when (predicate a) (action a)
291 | {-# INLINE cfilter #-}
292 | 
293 | {- | Performs the given logging action only if satisfies the monadic
294 | predicate. Let's say you want to only to see logs that happened on
295 | weekends.
296 | 
297 | @
298 | isWeekendM :: MessageWithTimestamp -> IO Bool
299 | @
300 | 
301 | And use it with 'cfilterM' like this
302 | 
303 | @
304 | logMessageAction :: 'LogAction' m MessageWithTimestamp
305 | 
306 | logWeekendAction :: 'LogAction' m MessageWithTimestamp
307 | logWeekendAction = cfilterM isWeekendM logMessageAction
308 | @
309 | 
310 | @since 0.2.1.0
311 | -}
312 | cfilterM :: Monad m => (msg -> m Bool) -> LogAction m msg -> LogAction m msg
313 | cfilterM predicateM (LogAction action) =
314 |     LogAction $ \a -> predicateM a >>= \b -> when b (action a)
315 | {-# INLINE cfilterM #-}
316 | 
317 | {- | This combinator is @contramap@ from contravariant functor. It is useful
318 | when you have something like
319 | 
320 | @
321 | __data__ LogRecord = LR
322 |     { lrName    :: LoggerName
323 |     , lrMessage :: Text
324 |     }
325 | @
326 | 
327 | and you need to provide 'LogAction' which consumes @LogRecord@
328 | 
329 | @
330 | logRecordAction :: 'LogAction' m LogRecord
331 | @
332 | 
333 | when you only have action that consumes 'Text'
334 | 
335 | @
336 | logTextAction :: 'LogAction' m Text
337 | @
338 | 
339 | With 'cmap' you can do the following:
340 | 
341 | @
342 | logRecordAction :: 'LogAction' m LogRecord
343 | logRecordAction = 'cmap' lrMesssage logTextAction
344 | @
345 | 
346 | This action will print only @lrMessage@ from @LogRecord@. But if you have
347 | formatting function like this:
348 | 
349 | @
350 | formatLogRecord :: LogRecord -> Text
351 | @
352 | 
353 | you can apply it instead of @lrMessage@ to log formatted @LogRecord@ as 'Text'.
354 | -}
355 | cmap :: (a -> b) -> LogAction m b -> LogAction m a
356 | cmap f (LogAction action) = LogAction (action . f)
357 | {-# INLINE cmap #-}
358 | 
359 | {- | Operator version of 'cmap'.
360 | 
361 | >>> 1 &> (show >$< logStringStdout)
362 | 1
363 | -}
364 | infixr 3 >$<
365 | (>$<) :: (a -> b) -> LogAction m b -> LogAction m a
366 | (>$<) = cmap
367 | {-# INLINE (>$<) #-}
368 | 
369 | -- | 'cmap' for convertions that may fail
370 | cmapMaybe :: Applicative m => (a -> Maybe b) -> LogAction m b -> LogAction m a
371 | cmapMaybe f (LogAction action) = LogAction (maybe (pure ()) action . f)
372 | {-# INLINE cmapMaybe #-}
373 | 
374 | {- | Similar to `cmapMaybe` but for convertions that may fail inside a
375 | monadic context.
376 | 
377 | @since 0.2.1.0
378 | -}
379 | cmapMaybeM :: Monad m => (a -> m (Maybe b)) -> LogAction m b -> LogAction m a
380 | cmapMaybeM f (LogAction action) = LogAction (maybe (pure ()) action <=< f)
381 | {-# INLINE cmapMaybeM #-}
382 | 
383 | {- | This combinator is @>$@ from contravariant functor. Replaces all locations
384 | in the output with the same value. The default definition is
385 | @contramap . const@, so this is a more efficient version.
386 | 
387 | >>> "Hello?" &> ("OUT OF SERVICE" >$ logStringStdout)
388 | OUT OF SERVICE
389 | >>> ("OUT OF SERVICE" >$ logStringStdout) <& 42
390 | OUT OF SERVICE
391 | -}
392 | infixl 4 >$
393 | (>$) :: b -> LogAction m b -> LogAction m a
394 | (>$) b (LogAction action) = LogAction (\_ -> action b)
395 | 
396 | {- | 'cmapM' combinator is similar to 'cmap' but allows to call monadic
397 | functions (functions that require extra context) to extend consumed value.
398 | Consider the following example.
399 | 
400 | You have this logging record:
401 | 
402 | @
403 | __data__ LogRecord = LR
404 |     { lrTime    :: UTCTime
405 |     , lrMessage :: Text
406 |     }
407 | @
408 | 
409 | and you also have logging consumer inside 'IO' for such record:
410 | 
411 | @
412 | logRecordAction :: 'LogAction' IO LogRecord
413 | @
414 | 
415 | But you need to return consumer only for 'Text' messages:
416 | 
417 | @
418 | logTextAction :: 'LogAction' IO Text
419 | @
420 | 
421 | If you have function that can extend 'Text' to @LogRecord@ like the function
422 | below:
423 | 
424 | @
425 | withTime :: 'Text' -> 'IO' LogRecord
426 | withTime msg = __do__
427 |     time <- getCurrentTime
428 |     pure (LR time msg)
429 | @
430 | 
431 | you can achieve desired behavior with 'cmapM' in the following way:
432 | 
433 | @
434 | logTextAction :: 'LogAction' IO Text
435 | logTextAction = 'cmapM' withTime myAction
436 | @
437 | -}
438 | cmapM :: Monad m => (a -> m b) -> LogAction m b -> LogAction m a
439 | cmapM f (LogAction action) = LogAction (f >=> action)
440 | {-# INLINE cmapM #-}
441 | 
442 | ----------------------------------------------------------------------------
443 | -- Divisible combinators
444 | ----------------------------------------------------------------------------
445 | 
446 | {- $divisible
447 | 
448 | Combinators that implement interface in the spirit of the following typeclass:
449 | 
450 | @
451 | __class__ Contravariant f => Divisible f __where__
452 |     conquer :: f a
453 |     divide  :: (a -> (b, c)) -> f b -> f c -> f a
454 | @
455 | -}
456 | 
457 | {- | @divide@ combinator from @Divisible@ type class.
458 | 
459 | >>> logInt = LogAction print
460 | >>> "ABC" &> divide (\s -> (s, length s)) logStringStdout logInt
461 | ABC
462 | 3
463 | -}
464 | divide :: (Applicative m) => (a -> (b, c)) -> LogAction m b -> LogAction m c -> LogAction m a
465 | divide f (LogAction actionB) (LogAction actionC) = LogAction $ \(f -> (b, c)) ->
466 |     actionB b *> actionC c
467 | {-# INLINE divide #-}
468 | 
469 | {- | Monadic version of 'divide'.
470 | 
471 | @since 0.2.1.0
472 | -}
473 | divideM :: (Monad m) => (a -> m (b, c)) -> LogAction m b -> LogAction m c -> LogAction m a
474 | divideM f (LogAction actionB) (LogAction actionC) =
475 |     LogAction $ \(f -> mbc) -> mbc >>= (\(b, c) -> actionB b *> actionC c)
476 | {-# INLINE divideM #-}
477 | 
478 | {- | @conquer@ combinator from @Divisible@ type class.
479 | 
480 | Concretely, this is a 'LogAction' that does nothing:
481 | 
482 | >>> conquer <& "hello?"
483 | >>> "hello?" &> conquer
484 | -}
485 | conquer :: Applicative m => LogAction m a
486 | conquer = mempty
487 | {-# INLINE conquer #-}
488 | 
489 | {- | Operator version of @'divide' 'id'@.
490 | 
491 | >>> logInt = LogAction print
492 | >>> (logStringStdout >*< logInt) <& ("foo", 1)
493 | foo
494 | 1
495 | >>> (logInt >*< logStringStdout) <& (1, "foo")
496 | 1
497 | foo
498 | -}
499 | infixr 4 >*<
500 | (>*<) :: (Applicative m) => LogAction m a -> LogAction m b -> LogAction m (a, b)
501 | (LogAction actionA) >*< (LogAction actionB) = LogAction $ \(a, b) ->
502 |     actionA a *> actionB b
503 | {-# INLINE (>*<) #-}
504 | 
505 | {-| Perform a constant log action after another.
506 | 
507 | >>> logHello = LogAction (const (putStrLn "Hello!"))
508 | >>> "Greetings!" &> (logStringStdout >* logHello)
509 | Greetings!
510 | Hello!
511 | -}
512 | infixr 4 >*
513 | (>*) :: Applicative m => LogAction m a -> LogAction m () -> LogAction m a
514 | (LogAction actionA) >* (LogAction actionB) = LogAction $ \a ->
515 |     actionA a *> actionB ()
516 | {-# INLINE (>*) #-}
517 | 
518 | -- | A flipped version of '>*'
519 | infixr 4 *<
520 | (*<) :: Applicative m => LogAction m () -> LogAction m a -> LogAction m a
521 | (LogAction actionA) *< (LogAction actionB) = LogAction $ \a ->
522 |     actionA () *> actionB a
523 | {-# INLINE (*<) #-}
524 | 
525 | ----------------------------------------------------------------------------
526 | -- Decidable combinators
527 | ----------------------------------------------------------------------------
528 | 
529 | {- $decidable
530 | 
531 | Combinators that implement interface in the spirit of the following typeclass:
532 | 
533 | @
534 | __class__ Divisible f => Decidable f __where__
535 |     lose   :: (a -> Void) -> f a
536 |     choose :: (a -> Either b c) -> f b -> f c -> f a
537 | @
538 | -}
539 | 
540 | -- | @lose@ combinator from @Decidable@ type class.
541 | lose :: (a -> Void) -> LogAction m a
542 | lose f = LogAction (absurd . f)
543 | {-# INLINE lose #-}
544 | 
545 | {- | @choose@ combinator from @Decidable@ type class.
546 | 
547 | >>> logInt = LogAction print
548 | >>> f = choose (\a -> if a < 0 then Left "Negative" else Right a)
549 | >>> f logStringStdout logInt <& 1
550 | 1
551 | >>> f logStringStdout logInt <& (-1)
552 | Negative
553 | -}
554 | choose :: (a -> Either b c) -> LogAction m b -> LogAction m c -> LogAction m a
555 | choose f (LogAction actionB) (LogAction actionC) = LogAction (either actionB actionC . f)
556 | {-# INLINE choose #-}
557 | 
558 | {- | Monadic version of 'choose'.
559 | 
560 | @since 0.2.1.0
561 | -}
562 | chooseM :: Monad m => (a -> m (Either b c)) -> LogAction m b -> LogAction m c -> LogAction m a
563 | chooseM f (LogAction actionB) (LogAction actionC) = LogAction (either actionB actionC <=< f)
564 | {-# INLINE chooseM #-}
565 | 
566 | {- | Operator version of @'choose' 'id'@.
567 | 
568 | >>> dontPrintInt = LogAction (const (putStrLn "Not printing Int"))
569 | >>> Left 1 &> (dontPrintInt >|< logStringStdout)
570 | Not printing Int
571 | >>> (dontPrintInt >|< logStringStdout) <& Right ":)"
572 | :)
573 | -}
574 | infixr 3 >|<
575 | (>|<) :: LogAction m a -> LogAction m b -> LogAction m (Either a b)
576 | (LogAction actionA) >|< (LogAction actionB) = LogAction (either actionA actionB)
577 | {-# INLINE (>|<) #-}
578 | 
579 | ----------------------------------------------------------------------------
580 | -- Comonadic combinators
581 | ----------------------------------------------------------------------------
582 | 
583 | {- $comonad
584 | 
585 | Combinators that implement interface in the spirit of the following typeclass:
586 | 
587 | @
588 | __class__ Functor w => Comonad w __where__
589 |     extract   :: w a -> a
590 |     duplicate :: w a -> w (w a)
591 |     extend    :: (w a -> b) -> w a -> w b
592 | @
593 | -}
594 | 
595 | {- | If @msg@ is 'Monoid' then 'extract' performs given log action by passing
596 | 'mempty' to it.
597 | 
598 | >>> logPrint :: LogAction IO [Int]; logPrint = LogAction print
599 | >>> extract logPrint
600 | []
601 | -}
602 | extract :: Monoid msg => LogAction m msg -> m ()
603 | extract action = unLogAction action mempty
604 | {-# INLINE extract #-}
605 | 
606 | -- TODO: write better motivation for comonads
607 | {- | This is a /comonadic extend/. It allows you to chain different transformations on messages.
608 | 
609 | >>> f (LogAction l) = l ".f1" *> l ".f2"
610 | >>> g (LogAction l) = l ".g"
611 | >>> logStringStdout <& "foo"
612 | foo
613 | >>> extend f logStringStdout <& "foo"
614 | foo.f1
615 | foo.f2
616 | >>> (extend g $ extend f logStringStdout) <& "foo"
617 | foo.g.f1
618 | foo.g.f2
619 | >>> (logStringStdout =>> f =>> g) <& "foo"
620 | foo.g.f1
621 | foo.g.f2
622 | -}
623 | extend :: Semigroup msg => (LogAction m msg -> m ()) -> LogAction m msg -> LogAction m msg
624 | extend f (LogAction action) = LogAction $ \m -> f $ LogAction $ \m' -> action (m <> m')
625 | {-# INLINE extend #-}
626 | 
627 | -- | 'extend' with the arguments swapped. Dual to '>>=' for a 'Monad'.
628 | infixl 1 =>>
629 | (=>>) :: Semigroup msg => LogAction m msg -> (LogAction m msg -> m ()) -> LogAction m msg
630 | (=>>) = flip extend
631 | {-# INLINE (=>>) #-}
632 | 
633 | -- | 'extend' in operator form.
634 | infixr 1 <<=
635 | (<<=) :: Semigroup msg => (LogAction m msg -> m ()) -> LogAction m msg -> LogAction m msg
636 | (<<=) = extend
637 | {-# INLINE (<<=) #-}
638 | 
639 | {- | Converts any 'LogAction' that can log single message to the 'LogAction'
640 | that can log two messages. The new 'LogAction' behaves in the following way:
641 | 
642 | 1. Joins two messages of type @msg@ using '<>' operator from 'Semigroup'.
643 | 2. Passes resulted message to the given 'LogAction'.
644 | 
645 | >>> :{
646 | let logger :: LogAction IO [Int]
647 |     logger = logPrint
648 | in duplicate logger <& ([3, 4], [42, 10])
649 | :}
650 | [3,4,42,10]
651 | 
652 | __Implementation note:__
653 | 
654 | True and fair translation of the @duplicate@ function from the 'Control.Comonad.Comonad'
655 | interface should result in the 'LogAction' of the following form:
656 | 
657 | @
658 | msg -> msg -> m ()
659 | @
660 | 
661 | In order to capture this behavior, 'duplicate' should have the following type:
662 | 
663 | @
664 | duplicate :: Semigroup msg => LogAction m msg -> LogAction (Compose ((->) msg) m) msg
665 | @
666 | 
667 | However, it's quite awkward to work with such type. It's a known fact that the
668 | following two types are isomorphic (see functions 'curry' and 'uncurry'):
669 | 
670 | @
671 | a -> b -> c
672 | (a, b) -> c
673 | @
674 | 
675 | So using this fact we can come up with the simpler interface.
676 | -}
677 | duplicate :: forall msg m . Semigroup msg => LogAction m msg -> LogAction m (msg, msg)
678 | duplicate (LogAction l) = LogAction $ \(msg1, msg2) -> l (msg1 <> msg2)
679 | {-# INLINE duplicate #-}
680 | 
681 | 
682 | {- | Like 'duplicate' but why stop on a pair of two messages if you can log any
683 | 'Foldable' of messages?
684 | 
685 | >>> :{
686 | let logger :: LogAction IO [Int]
687 |     logger = logPrint
688 | in multiplicate logger <& replicate 5 [1..3]
689 | :}
690 | [1,2,3,1,2,3,1,2,3,1,2,3,1,2,3]
691 | -}
692 | multiplicate
693 |     :: forall f msg m .
694 |        (Foldable f, Monoid msg)
695 |     => LogAction m msg
696 |     -> LogAction m (f msg)
697 | multiplicate (LogAction l) = LogAction $ \msgs -> l (fold msgs)
698 | {-# INLINE multiplicate #-}
699 | {-# SPECIALIZE multiplicate :: Monoid msg => LogAction m msg -> LogAction m [msg] #-}
700 | {-# SPECIALIZE multiplicate :: Monoid msg => LogAction m msg -> LogAction m (NonEmpty msg) #-}
701 | 
702 | {- | Like 'multiplicate' but instead of logging a batch of messages it logs each
703 | of them separately.
704 | 
705 | >>> :{
706 | let logger :: LogAction IO Int
707 |     logger = logPrint
708 | in separate logger <& [1..5]
709 | :}
710 | 1
711 | 2
712 | 3
713 | 4
714 | 5
715 | 
716 | @since 0.2.1.0
717 | -}
718 | separate
719 |     :: forall f msg m .
720 |        (Traversable f, Applicative m)
721 |     => LogAction m msg
722 |     -> LogAction m (f msg)
723 | separate (LogAction action) = LogAction (traverse_ action)
724 | {-# INLINE separate #-}
725 | {-# SPECIALIZE separate :: Applicative m => LogAction m msg -> LogAction m [msg] #-}
726 | {-# SPECIALIZE separate :: Applicative m => LogAction m msg -> LogAction m (NonEmpty msg) #-}
727 | {-# SPECIALIZE separate :: LogAction IO msg -> LogAction IO [msg] #-}
728 | {-# SPECIALIZE separate :: LogAction IO msg -> LogAction IO (NonEmpty msg) #-}
729 | 
730 | {- | Allows changing the internal monadic action.
731 | 
732 | Let's say we have a pure logger action using 'PureLogger'
733 | and we want to log all messages into 'IO' instead.
734 | 
735 | If we provide the following function:
736 | 
737 | @
738 | performPureLogsInIO :: PureLogger a -> IO a
739 | @
740 | 
741 | then we can convert a logger action that uses a pure monad
742 | to a one that performs the logging in the 'IO' monad using:
743 | 
744 | @
745 | hoistLogAction performPureLogsInIO :: LogAction (PureLogger a) a -> LogAction IO a
746 | @
747 | 
748 | @since 0.2.1.0
749 | -}
750 | hoistLogAction
751 |     :: (forall x. m x -> n x)
752 |     -> LogAction m a
753 |     -> LogAction n a
754 | hoistLogAction f (LogAction l) = LogAction (f . l)
755 | {-# INLINE hoistLogAction #-}
756 | 


--------------------------------------------------------------------------------