gdritter repos bock / 5f9886d
Basic sketch of quick-and-dirty logging framework Getty Ritter 6 years ago
7 changed file(s) with 206 addition(s) and 0 deletion(s). Collapse all Expand all
+3
-0
.gitignore less more
1 *~
2 .ghc.*
3 dist-newstyle
+12
-0
LICENSE less more
1 Copyright (c) 2017, Getty Ritter
2 All rights reserved.
3
4 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5
6 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7
8 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9
10 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11
12 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+32
-0
bock.cabal less more
1 name: bock
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter <samothes@infinitenegativeutility.com>
8 maintainer: Getty Ritter <samothes@infinitenegativeutility.com>
9 copyright: ©2017 Getty Ritter
10 -- category:
11 build-type: Simple
12 cabal-version: >= 1.14
13
14 library
15 hs-source-dirs: src
16 if os(windows)
17 hs-source-dirs: color/default
18 else
19 hs-source-dirs: color/unix
20 build-depends: unix
21 exposed-modules: Logging.Bock
22 other-modules: Logging.Bock.Color
23 ghc-options: -Wall
24 build-depends: base >=4.7 && <5
25 default-language: Haskell2010
26 default-extensions: OverloadedStrings,
27 ScopedTypeVariables
28
29 executable example
30 hs-source-dirs: example
31 main-is: Main.hs
32 build-depends: base, bock⏎
+6
-0
color/default/Logging/Bock/Color.hs less more
1 module Logging.Bock.Color (supportsColor) where
2
3 import qualified GHC.IO.Handle as IO
4
5 supportsColor :: IO.Handle -> IO Bool
6 supportsColor _ = pure False
+14
-0
color/unix/Logging/Bock/Color.hs less more
1 module Logging.Bock.Color (supportsColor) where
2
3 import qualified GHC.IO.Handle as IO
4 import qualified System.Posix.IO as Posix
5 import qualified System.Posix.Terminal as Posix
6
7 supportsColor :: IO.Handle -> IO Bool
8 supportsColor original = do
9 -- we need to duplicate the handle before turning it into an FD as
10 -- converting it to an FD will clone it, and that's... not what we
11 -- want
12 handle <- IO.hDuplicate original
13 fd <- Posix.handleToFd handle
14 Posix.queryTerminal fd
+11
-0
example/Main.hs less more
1 module Main where
2
3 import qualified Logging.Bock as Log
4
5 main :: IO ()
6 main = do
7 Log.debug ["debug-level message"]
8 Log.info ["info-level message"]
9 Log.warn ["warning-level message"]
10 Log.error ["error-level message"]
11 Log.critical ["critical-level message"]
+128
-0
src/Logging/Bock.hs less more
1 module Logging.Bock
2 ( debug
3 , info
4 , warn
5 , error
6 , critical
7
8 , Logger
9 , Level(..)
10 , setLogger
11 , mkLogger
12 ) where
13
14 import Control.Monad (when)
15 import qualified Control.Monad.IO.Class as IOClass
16 import qualified Data.Char as Char
17 import qualified Data.IORef as IORef
18 import qualified GHC.Stack as GHC
19 import qualified System.Environment as Env
20 import qualified System.IO as IO
21 import qualified System.IO.Unsafe as Unsafe
22 import Prelude hiding (log, error)
23
24 import Logging.Bock.Color (supportsColor)
25
26 data Logger = Logger
27 { logUseColors :: !Bool
28 , logWrite :: !(String -> IO ())
29 , logLevel :: !Level
30 }
31
32 data Level
33 = Debug
34 | Info
35 | Warn
36 | Error
37 | Critical
38 deriving (Eq, Show, Ord)
39
40 parseLevel :: String -> Maybe Level
41 parseLevel s = case map Char.toUpper s of
42 "DEBUG" -> Just Debug
43 "INFO" -> Just Info
44 "WARN" -> Just Warn
45 "ERROR" -> Just Error
46 "CRITICAL" -> Just Critical
47 _ -> Nothing
48
49 colorCode :: Level -> String
50 colorCode Debug = "\x1b[94m"
51 colorCode Info = ""
52 colorCode Warn = "\x1b[93m"
53 colorCode Error = "\x1b[91m"
54 colorCode Critical = "\x1b[91m"
55
56 endColorCode :: String
57 endColorCode = "\x1b[39m"
58
59 -- for pretty-printing the locations of the log messages
60 type Loc = Maybe (String, Int)
61
62 getLoc :: GHC.CallStack -> Loc
63 getLoc stack = case GHC.getCallStack stack of
64 [] -> Nothing
65 (_, loc):_ -> Just (GHC.srcLocModule loc, GHC.srcLocStartLine loc)
66
67 showLoc :: Monad m => (String -> m ()) -> Loc -> m ()
68 showLoc _ Nothing = pure ()
69 showLoc f (Just (md, ln)) = mapM_ f ["[", md, ":", show ln, "]: "]
70
71 defaultLogger :: IORef.IORef Logger
72 defaultLogger = Unsafe.unsafePerformIO $ do
73 levelMb <- Env.lookupEnv "LOG_LEVEL"
74 let level = case levelMb of
75 Just str | Just lvl <- parseLevel str -> lvl
76 _ -> Info
77 locMb <- Env.lookupEnv "LOG_LOCATION"
78 logger <- mkLogger level =<< case locMb of
79 Just path -> IO.openFile path IO.WriteMode
80 Nothing -> pure IO.stderr
81 IORef.newIORef logger
82
83 setLogger :: Logger -> IO ()
84 setLogger = IORef.writeIORef defaultLogger
85
86 mkLogger :: Level -> IO.Handle -> IO Logger
87 mkLogger level h = do
88 useColors <- supportsColor h
89 pure Logger
90 { logUseColors = useColors
91 , logWrite = \ msg -> IO.hPutStr h msg >> IO.hFlush h
92 , logLevel = level
93 }
94
95 class IOClass.MonadIO m => HasLogger m where
96 getLogger :: m Logger
97
98 instance HasLogger IO where
99 getLogger = IORef.readIORef defaultLogger
100
101
102
103 log :: HasLogger m => Level -> Loc -> [String] -> m ()
104 log lvl loc msg = do
105 l <- getLogger
106 when (lvl >= logLevel l) $ IOClass.liftIO $ do
107 when (logUseColors l) $
108 logWrite l (colorCode lvl)
109 showLoc (logWrite l) loc
110 logWrite l (unwords msg)
111 when (logUseColors l) $
112 logWrite l endColorCode
113 logWrite l "\n"
114
115 debug :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
116 debug = log Debug (getLoc GHC.callStack)
117
118 info :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
119 info = log Info (getLoc GHC.callStack)
120
121 warn :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
122 warn = log Warn (getLoc GHC.callStack)
123
124 error :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
125 error = log Error (getLoc GHC.callStack)
126
127 critical :: (GHC.HasCallStack, HasLogger m) => [String] -> m ()
128 critical = log Critical (getLoc GHC.callStack)