{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      :  BuildEnv.Utils

-- Description :  Utilities for @build-env@

--

-- Various utilities:

--

--  - Spawning of processes in particular environments; see 'callProcessInIO'.

--  - Semaphores.

--

module BuildEnv.Utils
    ( -- * Call a process in a given environment

      ProgPath(..), CallProcess(..), callProcessInIO

      -- * Create temporary directories

    , TempDirPermanence(..)
    , withTempDir

      -- * Abstract semaphores

    , AbstractSem(..)
    , withNewAbstractSem, noSem, abstractQSem

      -- * Other utilities

    , splitOn

    ) where

-- base

import Control.Concurrent.QSem
  ( QSem, newQSem, signalQSem, waitQSem )
import Control.Exception
  ( bracket, bracket_ )
import Data.Kind
  ( Type )
import Data.List
  ( intercalate )
import Data.Maybe
  ( maybeToList )
import Data.IORef
  ( readIORef )
import System.Environment
  ( getEnvironment )
import System.Exit
  ( ExitCode(..), exitWith )
import System.IO
  ( IOMode(..), hPutStrLn, withFile )
import qualified System.IO as System.Handle
  ( stderr )
import GHC.IO.Handle
  ( hDuplicateTo )
import GHC.Stack
  ( HasCallStack )

-- containers

import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( alter, fromList, toList )

-- directory

import System.Directory
  ( createDirectoryIfMissing )

-- filepath

import System.FilePath
  ( takeDirectory )

-- process

import qualified System.Process as Proc

-- semaphore-compat

import qualified System.Semaphore as System
  ( Semaphore(..), SemaphoreName(..)
  , freshSemaphore, openSemaphore
  , destroySemaphore
  , waitOnSemaphore, releaseSemaphore
  )

-- temporary

import System.IO.Temp
    ( createTempDirectory
    , getCanonicalTemporaryDirectory
    , withSystemTempDirectory
    )

-- build-env

import BuildEnv.Config
  ( Args, AsyncSem(..)
  , Counter(..)
  , TempDirPermanence(..)
  , pATHSeparator, hostStyle
  )
import BuildEnv.Path

--------------------------------------------------------------------------------


-- | The path of a program to run.

type ProgPath :: Type -> Type
data ProgPath from
  -- | An absolute path, or an executable in @PATH@.

  = AbsPath { forall from. ProgPath from -> AbsolutePath 'File
absProgPath :: !( AbsolutePath File ) }
  -- | A relative path, relative to the @from@ abstract location.

  | RelPath { forall from. ProgPath from -> SymbolicPath from 'File
relProgPath :: !( SymbolicPath from File ) }

-- | Arguments to 'callProcess'.

data CallProcess dir
  = CP
  { forall dir. CallProcess dir -> SymbolicPath CWD ('Dir dir)
cwd          :: !( SymbolicPath CWD ( Dir dir ) )
     -- ^ Working directory.

  , forall dir. CallProcess dir -> [[Char]]
extraPATH    :: ![ FilePath ]
     -- ^ Absolute filepaths to add to PATH.

  , forall dir. CallProcess dir -> [([Char], [Char])]
extraEnvVars :: ![ ( String, String ) ]
     -- ^ Extra environment variables to add before running the command.

  , forall dir. CallProcess dir -> ProgPath dir
prog         :: !( ProgPath dir )
     -- ^ The program to run.

     --

     -- If it's a relative path, it should be relative to the @cwd@ field.

  , forall dir. CallProcess dir -> [[Char]]
args         :: !Args
     -- ^ Arguments to the program.

  , forall dir. CallProcess dir -> Maybe (AbsolutePath 'File)
logBasePath  :: !( Maybe ( AbsolutePath File ) )
     -- ^ Log @stdout@ to @basePath.stdout@ and @stderr@ to @basePath.stderr@.

  , forall dir. CallProcess dir -> AbstractSem
sem          :: !AbstractSem
     -- ^ Lock to take when calling the process

     -- and waiting for it to return, to avoid

     -- contention in concurrent situations.

  }

-- | Run a command and wait for it to complete.

--

-- Crashes if the process returns with non-zero exit code.

--

-- See 'CallProcess' for a description of the options.

callProcessInIO :: HasCallStack
                => Maybe Counter
                    -- ^ Optional counter. Used when the command fails,

                    -- to report the progress that has been made so far.

                -> CallProcess dir
                -> IO ()
callProcessInIO :: forall dir.
HasCallStack =>
Maybe Counter -> CallProcess dir -> IO ()
callProcessInIO Maybe Counter
mbCounter ( CP { SymbolicPath CWD ('Dir dir)
cwd :: forall dir. CallProcess dir -> SymbolicPath CWD ('Dir dir)
cwd :: SymbolicPath CWD ('Dir dir)
cwd, [[Char]]
extraPATH :: forall dir. CallProcess dir -> [[Char]]
extraPATH :: [[Char]]
extraPATH, [([Char], [Char])]
extraEnvVars :: forall dir. CallProcess dir -> [([Char], [Char])]
extraEnvVars :: [([Char], [Char])]
extraEnvVars, ProgPath dir
prog :: forall dir. CallProcess dir -> ProgPath dir
prog :: ProgPath dir
prog, [[Char]]
args :: forall dir. CallProcess dir -> [[Char]]
args :: [[Char]]
args, Maybe (AbsolutePath 'File)
logBasePath :: forall dir. CallProcess dir -> Maybe (AbsolutePath 'File)
logBasePath :: Maybe (AbsolutePath 'File)
logBasePath, AbstractSem
sem :: forall dir. CallProcess dir -> AbstractSem
sem :: AbstractSem
sem } ) = do
  AbsolutePath 'File
absProg <-
    case ProgPath dir
prog of
      AbsPath AbsolutePath 'File
p -> AbsolutePath 'File -> IO (AbsolutePath 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath 'File
p
      RelPath SymbolicPath dir 'File
p -> SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir 'File -> IO (AbsolutePath 'File)
forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir dir)
cwd SymbolicPath dir 'File
p
        -- Needs to be an absolute path, as per the @process@ documentation:

        --

        --   If cwd is provided, it is implementation-dependent whether

        --   relative paths are resolved with respect to cwd or the current

        --   working directory, so absolute paths should be used

        --   to ensure portability.

        --

        -- We always want the program to be interpreted relative to the cwd

        -- argument, so we prepend @cwd@ and then make it absolute.

  let argsStr :: [Char]
argsStr
        | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args = [Char]
""
        | Bool
otherwise = [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
args
      command :: [[Char]]
command =
        [ [Char]
"  > " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AbsolutePath 'File -> [Char]
forall a. Show a => a -> [Char]
show AbsolutePath 'File
absProg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
argsStr
        , [Char]
"  CWD = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath CWD ('Dir dir) -> [Char]
forall a. Show a => a -> [Char]
show SymbolicPath CWD ('Dir dir)
cwd ]
  Maybe [([Char], [Char])]
env <-
    if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
extraPATH Bool -> Bool -> Bool
&& [([Char], [Char])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], [Char])]
extraEnvVars
    then Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
    else do [([Char], [Char])]
env0 <- IO [([Char], [Char])]
getEnvironment
            let env1 :: Map [Char] [Char]
env1 = [([Char], [Char])] -> Map [Char] [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], [Char])] -> Map [Char] [Char])
-> [([Char], [Char])] -> Map [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
env0 [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
extraEnvVars
                env2 :: [([Char], [Char])]
env2 = Map [Char] [Char] -> [([Char], [Char])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map [Char] [Char] -> [([Char], [Char])])
-> Map [Char] [Char] -> [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> Map [Char] [Char] -> Map [Char] [Char]
forall k. Ord k => k -> [[Char]] -> Map k [Char] -> Map k [Char]
augmentSearchPath [Char]
"PATH" [[Char]]
extraPATH Map [Char] [Char]
env1
            Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])]))
-> Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just [([Char], [Char])]
env2
  let withHandles :: ( ( Proc.StdStream, Proc.StdStream ) -> IO () ) -> IO ()
      withHandles :: ((StdStream, StdStream) -> IO ()) -> IO ()
withHandles (StdStream, StdStream) -> IO ()
action = case Maybe (AbsolutePath 'File)
logBasePath of
        Maybe (AbsolutePath 'File)
Nothing -> (StdStream, StdStream) -> IO ()
action ( StdStream
Proc.Inherit, StdStream
Proc.Inherit )
        Just AbsolutePath 'File
logPath -> do
          let stdoutFile :: AbsolutePath 'File
stdoutFile = AbsolutePath 'File
logPath AbsolutePath 'File -> [Char] -> AbsolutePath 'File
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"stdout"
              stderrFile :: AbsolutePath 'File
stderrFile = AbsolutePath 'File
logPath AbsolutePath 'File -> [Char] -> AbsolutePath 'File
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"stderr"
          Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeDirectory ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ AbsolutePath 'File -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath 'File
logPath
          [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile ( AbsolutePath 'File -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath 'File
stdoutFile ) IOMode
AppendMode \ Handle
stdoutFileHandle ->
            [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile ( AbsolutePath 'File -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath 'File
stderrFile ) IOMode
AppendMode \ Handle
stderrFileHandle -> do
              Handle -> Handle -> IO ()
hDuplicateTo Handle
System.Handle.stderr Handle
stderrFileHandle
                -- Write stderr to the log file and to the terminal.

              Handle -> [Char] -> IO ()
hPutStrLn Handle
stdoutFileHandle ( [[Char]] -> [Char]
unlines [[Char]]
command )
              (StdStream, StdStream) -> IO ()
action ( Handle -> StdStream
Proc.UseHandle Handle
stdoutFileHandle, Handle -> StdStream
Proc.UseHandle Handle
stderrFileHandle )
  ((StdStream, StdStream) -> IO ()) -> IO ()
withHandles \ ( StdStream
stdoutStream, StdStream
stderrStream ) -> do
    let processArgs :: CreateProcess
processArgs =
          ( [Char] -> [[Char]] -> CreateProcess
Proc.proc ( AbsolutePath 'File -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath 'File
absProg ) [[Char]]
args )
            { Proc.cwd     = if getSymbolicPath cwd == "." then Nothing else Just ( getSymbolicPath cwd )
            , Proc.env     = env
            , Proc.std_out = stdoutStream
            , Proc.std_err = stderrStream }
    ExitCode
res <- AbstractSem -> forall r. IO r -> IO r
withAbstractSem AbstractSem
sem do
      (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- [Char]
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Proc.createProcess_ [Char]
"createProcess" CreateProcess
processArgs
        -- Use 'createProcess_' to avoid closing handles prematurely.

      ProcessHandle -> IO ExitCode
Proc.waitForProcess ProcessHandle
ph
    case ExitCode
res of
      ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitFailure Int
i -> do
        [[Char]]
progressReport <-
          case Maybe Counter
mbCounter of
            Maybe Counter
Nothing -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just ( Counter { IORef Word
counterRef :: IORef Word
$sel:counterRef:Counter :: Counter -> IORef Word
counterRef, Word
counterMax :: Word
$sel:counterMax:Counter :: Counter -> Word
counterMax } ) -> do
              Word
progress <- IORef Word -> IO Word
forall a. IORef a -> IO a
readIORef IORef Word
counterRef
              [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [ [Char]
"After " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word -> [Char]
forall a. Show a => a -> [Char]
show Word
progress [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word -> [Char]
forall a. Show a => a -> [Char]
show Word
counterMax ]
        let msg :: [[Char]]
msg = [ [Char]
"callProcess failed with non-zero exit code " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Command:" ]
                     [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
command [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
progressReport
        case StdStream
stderrStream of
          Proc.UseHandle Handle
errHandle ->
            Handle -> [Char] -> IO ()
hPutStrLn Handle
errHandle
              ( [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]]
msg [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"Logs are available at: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AbsolutePath 'File -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath 'File
logs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".{stdout, stderr}" | AbsolutePath 'File
logs <- Maybe (AbsolutePath 'File) -> [AbsolutePath 'File]
forall a. Maybe a -> [a]
maybeToList Maybe (AbsolutePath 'File)
logBasePath ] )
          StdStream
_ -> [Char] -> IO ()
putStrLn ([[Char]] -> [Char]
unlines [[Char]]
msg)
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
res

-- | Add filepaths to the given key in a key/value environment.

augmentSearchPath :: Ord k => k -> [FilePath] -> Map k String -> Map k String
augmentSearchPath :: forall k. Ord k => k -> [[Char]] -> Map k [Char] -> Map k [Char]
augmentSearchPath k
_   []    = Map k [Char] -> Map k [Char]
forall a. a -> a
id
augmentSearchPath k
var [[Char]]
paths = (Maybe [Char] -> Maybe [Char]) -> k -> Map k [Char] -> Map k [Char]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe [Char] -> Maybe [Char]
f k
var
  where
    pathsVal :: [Char]
pathsVal = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate (Style -> [Char]
pATHSeparator Style
hostStyle) [[Char]]
paths
    f :: Maybe [Char] -> Maybe [Char]
f Maybe [Char]
Nothing  = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
pathsVal
    f (Just [Char]
p) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
p [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Style -> [Char]
pATHSeparator Style
hostStyle) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
pathsVal)

-- | Perform an action with a fresh temporary directory.

withTempDir :: TempDirPermanence  -- ^ whether to delete the temporary directory

                                  -- after the action completes

            -> String             -- ^ directory name template

            -> ( AbsolutePath ( Dir Tmp ) -> IO a ) -- ^ action to perform

            -> IO a
withTempDir :: forall a.
TempDirPermanence
-> [Char] -> (AbsolutePath ('Dir Tmp) -> IO a) -> IO a
withTempDir TempDirPermanence
del [Char]
name AbsolutePath ('Dir Tmp) -> IO a
k =
  case TempDirPermanence
del of
    TempDirPermanence
DeleteTempDirs
      -> [Char] -> ([Char] -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
name ( AbsolutePath ('Dir Tmp) -> IO a
k (AbsolutePath ('Dir Tmp) -> IO a)
-> ([Char] -> AbsolutePath ('Dir Tmp)) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> AbsolutePath ('Dir Tmp)
forall (to :: FileOrDir). [Char] -> AbsolutePath to
mkAbsolutePath )
    TempDirPermanence
Don'tDeleteTempDirs
      -> do [Char]
root <- IO [Char]
getCanonicalTemporaryDirectory
            [Char] -> [Char] -> IO [Char]
createTempDirectory [Char]
root [Char]
name IO [Char] -> ([Char] -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( AbsolutePath ('Dir Tmp) -> IO a
k (AbsolutePath ('Dir Tmp) -> IO a)
-> ([Char] -> AbsolutePath ('Dir Tmp)) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> AbsolutePath ('Dir Tmp)
forall (to :: FileOrDir). [Char] -> AbsolutePath to
mkAbsolutePath )

-- | Utility list 'splitOn' function.

splitOn :: Char -> String -> [String]
splitOn :: Char -> [Char] -> [[Char]]
splitOn Char
c = [Char] -> [[Char]]
go
  where
    go :: [Char] -> [[Char]]
go [Char]
"" = []
    go [Char]
s
      | ([Char]
a,[Char]
as) <- (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) [Char]
s
      = [Char]
a [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
go (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
as)

--------------------------------------------------------------------------------

-- Semaphores.


-- | Abstract acquire/release mechanism.

newtype AbstractSem =
  AbstractSem { AbstractSem -> forall r. IO r -> IO r
withAbstractSem :: forall r. IO r -> IO r }

-- | Create a semaphore-based acquire/release mechanism.

withNewAbstractSem :: AsyncSem
                   -> ( AbstractSem -> Args -> IO r )
                      -- ^ the abstract semaphore to use, and extra

                      -- arguments to pass to @Setup configure@ for @ghc@

                   -> IO r
withNewAbstractSem :: forall r. AsyncSem -> (AbstractSem -> [[Char]] -> IO r) -> IO r
withNewAbstractSem AsyncSem
whatSem AbstractSem -> [[Char]] -> IO r
f =
  case AsyncSem
whatSem of
    NewQSem Word16
n -> do
      QSem
qsem <- Int -> IO QSem
newQSem ( Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n )
      AbstractSem -> [[Char]] -> IO r
f ( QSem -> AbstractSem
abstractQSem QSem
qsem ) []
    NewJSem Word16
n ->
      IO Semaphore -> (Semaphore -> IO ()) -> (Semaphore -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        ( [Char] -> Int -> IO Semaphore
System.freshSemaphore [Char]
"buildEnvSemaphore" ( Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n ) )
        Semaphore -> IO ()
System.destroySemaphore
        ((Semaphore -> IO r) -> IO r) -> (Semaphore -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \ Semaphore
jsem -> do
          let jsemName :: SemaphoreName
jsemName = Semaphore -> SemaphoreName
System.semaphoreName Semaphore
jsem
          AbstractSem -> [[Char]] -> IO r
f ( Semaphore -> AbstractSem
abstractJSem Semaphore
jsem ) [ SemaphoreName -> [Char]
jsemGhcArg SemaphoreName
jsemName ]
    ExistingJSem [Char]
jsemName -> do
      let jsemNm :: SemaphoreName
jsemNm = [Char] -> SemaphoreName
System.SemaphoreName [Char]
jsemName
      Semaphore
jsem <- SemaphoreName -> IO Semaphore
System.openSemaphore SemaphoreName
jsemNm
      AbstractSem -> [[Char]] -> IO r
f ( Semaphore -> AbstractSem
abstractJSem Semaphore
jsem ) [ SemaphoreName -> [Char]
jsemGhcArg SemaphoreName
jsemNm ]
  where
    jsemGhcArg :: System.SemaphoreName -> String
    jsemGhcArg :: SemaphoreName -> [Char]
jsemGhcArg ( System.SemaphoreName [Char]
jsemName ) =
      [Char]
"--ghc-option=-jsem=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
jsemName

-- | No acquire/release mechanism required.

noSem :: AbstractSem
noSem :: AbstractSem
noSem = AbstractSem { withAbstractSem :: forall r. IO r -> IO r
withAbstractSem = IO r -> IO r
forall a. a -> a
forall r. IO r -> IO r
id }

-- | Abstract acquire/release mechanism controlled by the given 'QSem'.

abstractQSem :: QSem -> AbstractSem
abstractQSem :: QSem -> AbstractSem
abstractQSem QSem
sem =
  (forall r. IO r -> IO r) -> AbstractSem
AbstractSem ((forall r. IO r -> IO r) -> AbstractSem)
-> (forall r. IO r -> IO r) -> AbstractSem
forall a b. (a -> b) -> a -> b
$
    IO () -> IO () -> IO r -> IO r
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
      ( QSem -> IO ()
waitQSem   QSem
sem )
      ( QSem -> IO ()
signalQSem QSem
sem )

-- | Abstract acquire/release mechanism controlled by the given

-- system semaphore.

abstractJSem :: System.Semaphore -> AbstractSem
abstractJSem :: Semaphore -> AbstractSem
abstractJSem Semaphore
sem =
  (forall r. IO r -> IO r) -> AbstractSem
AbstractSem ((forall r. IO r -> IO r) -> AbstractSem)
-> (forall r. IO r -> IO r) -> AbstractSem
forall a b. (a -> b) -> a -> b
$
    IO () -> IO () -> IO r -> IO r
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
      ( Semaphore -> IO ()
System.waitOnSemaphore  Semaphore
sem )
      ( Semaphore -> Int -> IO ()
System.releaseSemaphore Semaphore
sem Int
1 )