module Splint.Settings where

import qualified Control.Concurrent.STM as Stm
import qualified Control.Exception as Exception
import qualified Data.Map as Map
import qualified Language.Haskell.HLint as HLint
import qualified Splint.RemoteData as RemoteData
import qualified System.IO.Unsafe as Unsafe

type Settings = (HLint.ParseFlags, [HLint.Classify], HLint.Hint)

-- | Getting settings is not instantaneous. Since settings are usually reused
-- between modules, it makes sense to cache them. However each module can
-- potentially customize its settings using the @OPTIONS_GHC@ pragma. This
-- variable is used as a cache of settings keyed on the command line options.
cache
  :: Stm.TVar
       (Map.Map [String] (RemoteData.RemoteData Exception.IOException Settings))
cache :: TVar (Map [String] (RemoteData IOException Settings))
cache = IO (TVar (Map [String] (RemoteData IOException Settings)))
-> TVar (Map [String] (RemoteData IOException Settings))
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (TVar (Map [String] (RemoteData IOException Settings)))
 -> TVar (Map [String] (RemoteData IOException Settings)))
-> IO (TVar (Map [String] (RemoteData IOException Settings)))
-> TVar (Map [String] (RemoteData IOException Settings))
forall a b. (a -> b) -> a -> b
$ Map [String] (RemoteData IOException Settings)
-> IO (TVar (Map [String] (RemoteData IOException Settings)))
forall a. a -> IO (TVar a)
Stm.newTVarIO Map [String] (RemoteData IOException Settings)
forall k a. Map k a
Map.empty
{-# NOINLINE cache #-}

-- | Even though we cache settings based on command line options, we only want
-- to load settings one at a time. Practically this is to work around a bug in
-- GHC. But aside from that, loading settings calls @withArgs@ and doing that
-- simultaneously in separate threads is dubious.
-- <https://gitlab.haskell.org/ghc/ghc/issues/18261>
semaphore :: Stm.TMVar ()
semaphore :: TMVar ()
semaphore = IO (TMVar ()) -> TMVar ()
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (TMVar ()) -> TMVar ()) -> IO (TMVar ()) -> TMVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (TMVar ())
forall a. a -> IO (TMVar a)
Stm.newTMVarIO ()
{-# NOINLINE semaphore #-}

withTMVar :: Stm.TMVar a -> (a -> IO b) -> IO b
withTMVar :: TMVar a -> (a -> IO b) -> IO b
withTMVar TMVar a
x = IO a -> (a -> IO ()) -> (a -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
  (STM a -> IO a
forall a. STM a -> IO a
Stm.atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ TMVar a -> STM a
forall a. TMVar a -> STM a
Stm.takeTMVar TMVar a
x)
  (STM () -> IO ()
forall a. STM a -> IO a
Stm.atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
Stm.putTMVar TMVar a
x)

load :: [String] -> IO Settings
load :: [String] -> IO Settings
load [String]
commandLineOptions = do
  RemoteData IOException Settings
remoteData <- STM (RemoteData IOException Settings)
-> IO (RemoteData IOException Settings)
forall a. STM a -> IO a
Stm.atomically (STM (RemoteData IOException Settings)
 -> IO (RemoteData IOException Settings))
-> STM (RemoteData IOException Settings)
-> IO (RemoteData IOException Settings)
forall a b. (a -> b) -> a -> b
$ do
    Map [String] (RemoteData IOException Settings)
settings <- TVar (Map [String] (RemoteData IOException Settings))
-> STM (Map [String] (RemoteData IOException Settings))
forall a. TVar a -> STM a
Stm.readTVar TVar (Map [String] (RemoteData IOException Settings))
cache
    let
      remoteData :: RemoteData IOException Settings
remoteData =
        RemoteData IOException Settings
-> [String]
-> Map [String] (RemoteData IOException Settings)
-> RemoteData IOException Settings
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault RemoteData IOException Settings
forall e a. RemoteData e a
RemoteData.NotAsked [String]
commandLineOptions Map [String] (RemoteData IOException Settings)
settings
    case RemoteData IOException Settings
remoteData of
      RemoteData IOException Settings
RemoteData.NotAsked ->
        TVar (Map [String] (RemoteData IOException Settings))
-> (Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
Stm.modifyTVar TVar (Map [String] (RemoteData IOException Settings))
cache ((Map [String] (RemoteData IOException Settings)
  -> Map [String] (RemoteData IOException Settings))
 -> STM ())
-> (Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> STM ()
forall a b. (a -> b) -> a -> b
$ [String]
-> RemoteData IOException Settings
-> Map [String] (RemoteData IOException Settings)
-> Map [String] (RemoteData IOException Settings)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [String]
commandLineOptions RemoteData IOException Settings
forall e a. RemoteData e a
RemoteData.Loading
      RemoteData IOException Settings
RemoteData.Loading -> STM ()
forall a. STM a
Stm.retry
      RemoteData IOException Settings
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RemoteData IOException Settings
-> STM (RemoteData IOException Settings)
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteData IOException Settings
remoteData
  case RemoteData IOException Settings
remoteData of
    RemoteData IOException Settings
RemoteData.NotAsked -> TMVar () -> (() -> IO Settings) -> IO Settings
forall a b. TMVar a -> (a -> IO b) -> IO b
withTMVar TMVar ()
semaphore ((() -> IO Settings) -> IO Settings)
-> (IO Settings -> () -> IO Settings) -> IO Settings -> IO Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Settings -> () -> IO Settings
forall a b. a -> b -> a
const (IO Settings -> IO Settings) -> IO Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ do
      Either IOException Settings
result <- IO Settings -> IO (Either IOException Settings)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO Settings -> IO (Either IOException Settings))
-> IO Settings -> IO (Either IOException Settings)
forall a b. (a -> b) -> a -> b
$ [String] -> IO Settings
HLint.argsSettings [String]
commandLineOptions
      case Either IOException Settings
result of
        Left IOException
ioException -> do
          STM () -> IO ()
forall a. STM a -> IO a
Stm.atomically
            (STM () -> IO ())
-> (RemoteData IOException Settings -> STM ())
-> RemoteData IOException Settings
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map [String] (RemoteData IOException Settings))
-> (Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
Stm.modifyTVar TVar (Map [String] (RemoteData IOException Settings))
cache
            ((Map [String] (RemoteData IOException Settings)
  -> Map [String] (RemoteData IOException Settings))
 -> STM ())
-> (RemoteData IOException Settings
    -> Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> RemoteData IOException Settings
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String]
-> RemoteData IOException Settings
-> Map [String] (RemoteData IOException Settings)
-> Map [String] (RemoteData IOException Settings)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [String]
commandLineOptions
            (RemoteData IOException Settings -> IO ())
-> RemoteData IOException Settings -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> RemoteData IOException Settings
forall e a. e -> RemoteData e a
RemoteData.Failure IOException
ioException
          IOException -> IO Settings
forall e a. Exception e => e -> IO a
Exception.throwIO IOException
ioException
        Right Settings
settings -> do
          STM () -> IO ()
forall a. STM a -> IO a
Stm.atomically
            (STM () -> IO ())
-> (RemoteData IOException Settings -> STM ())
-> RemoteData IOException Settings
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map [String] (RemoteData IOException Settings))
-> (Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
Stm.modifyTVar TVar (Map [String] (RemoteData IOException Settings))
cache
            ((Map [String] (RemoteData IOException Settings)
  -> Map [String] (RemoteData IOException Settings))
 -> STM ())
-> (RemoteData IOException Settings
    -> Map [String] (RemoteData IOException Settings)
    -> Map [String] (RemoteData IOException Settings))
-> RemoteData IOException Settings
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String]
-> RemoteData IOException Settings
-> Map [String] (RemoteData IOException Settings)
-> Map [String] (RemoteData IOException Settings)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [String]
commandLineOptions
            (RemoteData IOException Settings -> IO ())
-> RemoteData IOException Settings -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings -> RemoteData IOException Settings
forall e a. a -> RemoteData e a
RemoteData.Success Settings
settings
          Settings -> IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings
settings
    RemoteData IOException Settings
RemoteData.Loading -> [String] -> IO Settings
load [String]
commandLineOptions
    RemoteData.Failure IOException
ioException -> IOException -> IO Settings
forall e a. Exception e => e -> IO a
Exception.throwIO IOException
ioException
    RemoteData.Success Settings
settings -> Settings -> IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings
settings