{-# LANGUAGE BlockArguments #-}

-- | This module is inspired by:
--
-- https://github.com/tfausak/splint/blob/9028a8b631568dc5d16a74153b1a9b6e3cde0fe6/src/lib/Splint/Settings.hs
--
-- … in order to work around this issue (just like @splint@ does):
--
-- <https://gitlab.haskell.org/ghc/ghc/issues/18261>
--
-- Without this workaround the GHC plugin will fail with something like this
-- error message:
--
-- > ghc-9.6.2(82937,0x16e83b000) malloc: *** error for object 0x600000a4d5c0: pointer being freed was not allocated
-- > ghc-9.6.2(82937,0x16e83b000) malloc: *** set a breakpoint in malloc_error_break to debug

module HLint.Plugin.Settings
    ( -- * Settings
      argsSettings
    ) where

import Control.Concurrent.MVar (MVar)
import Data.IORef (IORef)
import Data.Map (Map)
import Language.Haskell.HLint (Classify, Hint, ParseFlags)

import qualified Control.Concurrent.MVar as MVar
import qualified Data.IORef as IORef
import qualified Data.Map as Map
import qualified Language.Haskell.HLint as HLint
import qualified System.IO.Unsafe as Unsafe

cache :: IORef (Map [String] (IO (ParseFlags, [Classify], Hint)))
cache :: IORef (Map [String] (IO (ParseFlags, [Classify], Hint)))
cache = IO (IORef (Map [String] (IO (ParseFlags, [Classify], Hint))))
-> IORef (Map [String] (IO (ParseFlags, [Classify], Hint)))
forall a. IO a -> a
Unsafe.unsafePerformIO (Map [String] (IO (ParseFlags, [Classify], Hint))
-> IO (IORef (Map [String] (IO (ParseFlags, [Classify], Hint))))
forall a. a -> IO (IORef a)
IORef.newIORef Map [String] (IO (ParseFlags, [Classify], Hint))
forall k a. Map k a
Map.empty)
{-# NOINLINE cache #-}

semaphore :: MVar ()
semaphore :: MVar ()
semaphore = IO (MVar ()) -> MVar ()
forall a. IO a -> a
Unsafe.unsafePerformIO (() -> IO (MVar ())
forall a. a -> IO (MVar a)
MVar.newMVar ())
{-# NOINLINE semaphore #-}

-- | This is a drop-in replacement for
--   "Language.Haskell.HLint".`HLint.argsSettings`, except that this is safe to
--   run in parallel.
argsSettings
    :: [String]
    -> IO (ParseFlags, [Classify], Hint)
argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
key = do
    IO (ParseFlags, [Classify], Hint)
io <- IORef (Map [String] (IO (ParseFlags, [Classify], Hint)))
-> (Map [String] (IO (ParseFlags, [Classify], Hint))
    -> (Map [String] (IO (ParseFlags, [Classify], Hint)),
        IO (ParseFlags, [Classify], Hint)))
-> IO (IO (ParseFlags, [Classify], Hint))
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (Map [String] (IO (ParseFlags, [Classify], Hint)))
cache \Map [String] (IO (ParseFlags, [Classify], Hint))
m -> do
        case [String]
-> Map [String] (IO (ParseFlags, [Classify], Hint))
-> Maybe (IO (ParseFlags, [Classify], Hint))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [String]
key Map [String] (IO (ParseFlags, [Classify], Hint))
m of
            Maybe (IO (ParseFlags, [Classify], Hint))
Nothing      -> do
                let io :: IO (ParseFlags, [Classify], Hint)
io =
                        IO (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint)
forall a. IO a -> IO a
Unsafe.unsafeInterleaveIO do
                            MVar ()
-> (() -> IO (ParseFlags, [Classify], Hint))
-> IO (ParseFlags, [Classify], Hint)
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar MVar ()
semaphore \()
_ -> [String] -> IO (ParseFlags, [Classify], Hint)
HLint.argsSettings [String]
key

                ([String]
-> IO (ParseFlags, [Classify], Hint)
-> Map [String] (IO (ParseFlags, [Classify], Hint))
-> Map [String] (IO (ParseFlags, [Classify], Hint))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [String]
key IO (ParseFlags, [Classify], Hint)
io Map [String] (IO (ParseFlags, [Classify], Hint))
m, IO (ParseFlags, [Classify], Hint)
io)

            Just IO (ParseFlags, [Classify], Hint)
io ->
                (Map [String] (IO (ParseFlags, [Classify], Hint))
m, IO (ParseFlags, [Classify], Hint)
io)

    IO (ParseFlags, [Classify], Hint)
io