diff --git a/app/Environment.hs b/app/Environment.hs index ba5e8a0..1fd9108 100644 --- a/app/Environment.hs +++ b/app/Environment.hs @@ -11,11 +11,10 @@ module Environment(Env (..), EnvM, runEnvM, myLogAction,defaultEnv) where import Prelude hiding (log) import Colog import Control.Monad.Reader (ReaderT (..), MonadReader) -import Control.Monad.Trans +import Control.Monad.Trans(lift) import Control.Monad.IO.Unlift import Control.Concurrent.MVar (MVar,modifyMVar_,newMVar) import System.IO.Unsafe(unsafePerformIO) -import qualified Control.Concurrent.MVar as M import qualified Data.Text as T import qualified Data.Text.IO as T import Control.Parallel(pseq) @@ -43,17 +42,17 @@ instance MonadUnliftIO EnvM where withRunInIO inner = EnvM $ withRunInIO (\fromReader -> inner (fromReader . unEnvM)) {-# INLINE withRunInIO #-} -modifyMVar :: M.MVar a -> (a -> EnvM (a,b)) -> EnvM b -modifyMVar mvar action = withRunInIO $ \run -> M.modifyMVar mvar (run . action) - - runEnvM :: Env EnvM -> EnvM a -> IO a runEnvM env envm = runReaderT (unEnvM envm) env +-- we do not export this MVar (which makes it easier to reason about deadlocks syncMVar :: MVar () syncMVar = unsafePerformIO $ newMVar () {-# NOINLINE syncMVar #-} +-- Every time you do something like this you should ask yourself: Is this a potential deadlock? And the answer +-- is in this case is NO. Even if m diverges it won't be able to lock up other threads as it will be forced to +-- evaluate before we take the MVar. So as long printing to stdout terminates we will always put back the mvar. myLogAction :: LogAction EnvM Message myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m))