forced evaluation of logging message before blocking

This commit is contained in:
Dennis Frieberg 2021-04-14 10:48:59 +02:00
parent 069bf3fde8
commit b98e5e27d0
3 changed files with 6 additions and 1 deletions

View file

@ -18,6 +18,7 @@ import System.IO.Unsafe(unsafePerformIO)
import qualified Control.Concurrent.MVar as M import qualified Control.Concurrent.MVar as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Control.Parallel(pseq)
newtype Env m = Env {logAction :: LogAction m Message} newtype Env m = Env {logAction :: LogAction m Message}
@ -54,7 +55,7 @@ syncMVar = unsafePerformIO $ newMVar ()
{-# NOINLINE syncMVar #-} {-# NOINLINE syncMVar #-}
myLogAction :: LogAction EnvM Message myLogAction :: LogAction EnvM Message
myLogAction = LogAction $ \x -> EnvM . lift $ modifyMVar_ syncMVar (const (T.putStrLn . formatMessage $ x)) myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m))
formatMessage :: Message -> T.Text formatMessage :: Message -> T.Text
formatMessage Msg{..} = formatMessage Msg{..} =

View file

@ -49,6 +49,8 @@ dependencies:
- unliftio-core - unliftio-core
- unliftio - unliftio
- mtl - mtl
# for pseq in logging
- parallel
when: when:
- condition: flag(http) - condition: flag(http)

View file

@ -56,6 +56,7 @@ executable tickLeisteServer
, http-types , http-types
, mtl , mtl
, optparse-applicative , optparse-applicative
, parallel
, text , text
, tickLeiste , tickLeiste
, tickLeiste-aeson , tickLeiste-aeson
@ -97,6 +98,7 @@ test-suite tickLeisteServer-test
, http-types , http-types
, mtl , mtl
, optparse-applicative , optparse-applicative
, parallel
, text , text
, tickLeiste , tickLeiste
, tickLeiste-aeson , tickLeiste-aeson