-- | Facility for purely creating an 'IORef' in which to stash a value
--
-- Storing a truly global value can be useful for performance (e.g. to speed up
-- tests by caching a constructed App) or necessary to prevent contention (e.g.
-- by caching a single 'LoggerSet' which holds access to a log file).
--
-- In some cases, it's not possible to create an 'IORef' safely in an 'IO'
-- context to use for this purpose. Either because a library prevents it (e.g.
-- the test runner provides no such hook before triggering its parallel
-- execution) or because the current application architecture cannot allow it
-- without a high effort re-organization.
--
-- For these cases, we use this module.
--
-- == Usage
--
-- Given some function,
--
-- @
-- makeLogger :: HasLogging a => a -> IO Logger
-- makeLogger app = makeYesodLogger =<< newLoggerSet defaultBufSize
--  where
--   newLoggerSet = case getLogLocation app of
--     LogStdout -> newStdoutLoggerSet
--     LogStderr -> newStderrLoggerSet
--     LogFile f -> flip newFileLoggerSet f
-- @
--
-- Update it to cache the construction in a new top-level value,
--
-- @
-- loggerSetVar :: GlobalCache LoggerSet
-- loggerSetVar = unsafePerformIO newGlobalCache
-- {-# NOINLINE loggerSetVar #-}
--
-- makeLogger :: HasLogging a => a -> IO Logger
-- makeLogger app = makeYesodLogger
--   =<< globallyCache loggerSetVar (newLoggerSet defaultBufSize)
--  where
--   newLoggerSet = case getLogLocation app of
--     LogStdout -> newStdoutLoggerSet
--     LogStderr -> newStderrLoggerSet
--     LogFile f -> flip newFileLoggerSet f
-- @
--
module Freckle.App.GlobalCache
  ( GlobalCache
  , newGlobalCache
  , globallyCache
  , withGlobalCacheCleanup
  ) where

import Freckle.App.Prelude

import Control.Concurrent.MVar (mkWeakMVar, modifyMVar_, newMVar)
import Data.IORef

newtype GlobalCache a = GlobalCache
  { forall a. GlobalCache a -> IORef (Maybe a)
_unGlobalCache :: IORef (Maybe a)
  }

newGlobalCache :: IO (GlobalCache a)
newGlobalCache :: forall a. IO (GlobalCache a)
newGlobalCache = forall a. IORef (Maybe a) -> GlobalCache a
GlobalCache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing

globallyCache :: GlobalCache a -> IO a -> IO a
globallyCache :: forall a. GlobalCache a -> IO a -> IO a
globallyCache (GlobalCache IORef (Maybe a)
var) IO a
construct = do
  Maybe a
mv <- forall a. IORef a -> IO a
readIORef IORef (Maybe a)
var
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> IO a
cache forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
construct) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mv
  where cache :: a -> IO a
cache a
v = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe a)
var forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just a
v, a
v)

-- | Garbage collect one of our 'IORef's after an action has run
--
-- Global 'IORef's are problematic for @ghci@. @ghci@ cannot garbage collect
-- them, so any state they hold will persist for an entire @ghci@ session. This
-- causes a varietyof issues.
--
-- To avoid garbage collection issues, we can leverage a "System.Mem.Weak" to
-- add a finalizer. When that 'MVar' gets garbage collected we can clear the
-- global 'IORef'. This maintains the status quo, with minimal plumbing.
--
withGlobalCacheCleanup :: GlobalCache a -> IO b -> IO ()
withGlobalCacheCleanup :: forall a b. GlobalCache a -> IO b -> IO ()
withGlobalCacheCleanup (GlobalCache IORef (Maybe a)
var) IO b
action = do
  MVar ()
cleanup <- forall a. a -> IO (MVar a)
newMVar ()
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO () -> IO (Weak (MVar a))
mkWeakMVar MVar ()
cleanup forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
var forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Functor f => f a -> f ()
void IO b
action
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ()
cleanup (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())