{-# LANGUAGE CPP #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |

-- Module      :  BuildEnv.Config

-- Description :  Configuration options for @build-env@

--

-- Configuration options for @build-env@

module BuildEnv.Config
  ( -- * Build strategy

    BuildStrategy(..), RunStrategy(..)
  , AsyncSem(..), semDescription

   -- * Passing arguments

  , Args, UnitArgs(..)

    -- * @ghc@ and @cabal-install@ executables

  , Compiler(..), Cabal(..)

    -- * Hackage index state

  , IndexState(..)

    -- * Directory structure

  , Paths(..), BuildPaths(..)
  , PathUsability(..)
  , canonicalizePaths

    -- ** Handling of temporary directories

  , TempDirPermanence(..)

    -- * Logging verbosity

  , Verbosity(.., Quiet, Normal, Verbose, Debug)
  , quietMsg, normalMsg, verboseMsg, debugMsg
  , ghcVerbosity, ghcPkgVerbosity, cabalVerbosity, setupVerbosity

    -- * Reporting progress

  , Counter(..)

    -- * OS specifics

  , Style(..), hostStyle
  , pATHSeparator

  ) where

-- base

import Control.Monad
  ( when )
import Data.Kind
  ( Type )
import Data.IORef
  ( IORef )
import Data.Word
  ( Word16 )
import System.IO
  ( hFlush, stdout )

-- filepath

import System.FilePath
  ( dropDrive )

-- text

import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( pack )
import qualified Data.Text.IO as Text
  ( putStrLn )

-- time

import Data.Time.Clock
  ( getCurrentTime )
import Data.Time.Format
  ( defaultTimeLocale, formatTime )

-- build-env

import BuildEnv.Path

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

-- Build strategy


-- | Build strategy for 'BuildEnv.Build.buildPlan'.

data BuildStrategy
  -- | Execute the build plan in-place.

  = Execute RunStrategy
  -- | Output a build script that can be run later.

  | Script
    { BuildStrategy -> SymbolicPath CWD 'File
scriptPath   :: !( SymbolicPath CWD File )
      -- ^ Output path at which to write the build script.

    , BuildStrategy -> Bool
useVariables :: !Bool
      -- ^ Should the output shell script use variables, or baked in paths?

      --

      -- The shell script will use the following variables:

      --

      -- - @GHC@, @GHCPKG@, @SOURCES@, @PREFIX@, @DESTDIR@.

    }
  deriving stock Int -> BuildStrategy -> ShowS
[BuildStrategy] -> ShowS
BuildStrategy -> String
(Int -> BuildStrategy -> ShowS)
-> (BuildStrategy -> String)
-> ([BuildStrategy] -> ShowS)
-> Show BuildStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildStrategy -> ShowS
showsPrec :: Int -> BuildStrategy -> ShowS
$cshow :: BuildStrategy -> String
show :: BuildStrategy -> String
$cshowList :: [BuildStrategy] -> ShowS
showList :: [BuildStrategy] -> ShowS
Show

-- | How to execute a build plan.

data RunStrategy
  -- | Topologically sort the cabal build plan, and build the

  -- packages in sequence.

  = TopoSort

  -- | Asynchronously build all the packages, with each package

  -- waiting on its dependencies.

  | Async
     AsyncSem
       -- ^ The kind of semaphore to use to control concurrency.

  deriving stock Int -> RunStrategy -> ShowS
[RunStrategy] -> ShowS
RunStrategy -> String
(Int -> RunStrategy -> ShowS)
-> (RunStrategy -> String)
-> ([RunStrategy] -> ShowS)
-> Show RunStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunStrategy -> ShowS
showsPrec :: Int -> RunStrategy -> ShowS
$cshow :: RunStrategy -> String
show :: RunStrategy -> String
$cshowList :: [RunStrategy] -> ShowS
showList :: [RunStrategy] -> ShowS
Show

-- | What kind of semaphore to use in 'BuildEnv.Build.buildPlan'?

data AsyncSem
  -- | Create a new 'Control.Concurrent.QSem.QSem' semaphore

  -- with the given number of tokens.

  = NewQSem !Word16
  -- | Create a new system semaphore with the given number of tokens,

  -- passing it to @ghc@ invocations.

  | NewJSem !Word16
  -- | Use an existing system semaphore, passing it to @ghc@ invocations.

  | ExistingJSem !String
  deriving stock Int -> AsyncSem -> ShowS
[AsyncSem] -> ShowS
AsyncSem -> String
(Int -> AsyncSem -> ShowS)
-> (AsyncSem -> String) -> ([AsyncSem] -> ShowS) -> Show AsyncSem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AsyncSem -> ShowS
showsPrec :: Int -> AsyncSem -> ShowS
$cshow :: AsyncSem -> String
show :: AsyncSem -> String
$cshowList :: [AsyncSem] -> ShowS
showList :: [AsyncSem] -> ShowS
Show

-- | A description of the kind of semaphore we are using to control concurrency.

semDescription :: AsyncSem -> Text
semDescription :: AsyncSem -> Text
semDescription = \case
  NewQSem Word16
i -> Text
"-j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
i)
  NewJSem Word16
i -> Text
"--jsem " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
i)
  ExistingJSem String
jsemName ->
    Text
"--jsem " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
jsemName

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

-- Arguments


-- | A type synonym for command-line arguments.

type Args = [String]

-- | Arguments specific to a unit.

data UnitArgs =
  UnitArgs { UnitArgs -> Args
configureArgs :: !Args
               -- ^ Arguments to @Setup configure@.

           , UnitArgs -> Maybe Args
mbHaddockArgs :: !(Maybe Args)
               -- ^ Arguments to @Setup haddock@.

               -- @Nothing@ means: skip @Setup haddock@.

           , UnitArgs -> Args
registerArgs  :: !Args
               -- ^ Arguments to @ghc-pkg register@.

           }
  deriving stock Int -> UnitArgs -> ShowS
[UnitArgs] -> ShowS
UnitArgs -> String
(Int -> UnitArgs -> ShowS)
-> (UnitArgs -> String) -> ([UnitArgs] -> ShowS) -> Show UnitArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnitArgs -> ShowS
showsPrec :: Int -> UnitArgs -> ShowS
$cshow :: UnitArgs -> String
show :: UnitArgs -> String
$cshowList :: [UnitArgs] -> ShowS
showList :: [UnitArgs] -> ShowS
Show

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

-- GHC & cabal-install


-- | Path to the @cabal-install@ executable.

data Cabal = Cabal { Cabal -> AbsolutePath 'File
cabalPath       :: !( AbsolutePath File )
                   , Cabal -> Args
globalCabalArgs :: !Args
                     -- ^ Arguments to pass to all @cabal@ invocations,

                     -- before any @cabal@ command.

                   }
  deriving stock Int -> Cabal -> ShowS
[Cabal] -> ShowS
Cabal -> String
(Int -> Cabal -> ShowS)
-> (Cabal -> String) -> ([Cabal] -> ShowS) -> Show Cabal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cabal -> ShowS
showsPrec :: Int -> Cabal -> ShowS
$cshow :: Cabal -> String
show :: Cabal -> String
$cshowList :: [Cabal] -> ShowS
showList :: [Cabal] -> ShowS
Show

-- | Paths to the @ghc@ and @ghc-pkg@ executables.

data Compiler =
  Compiler { Compiler -> AbsolutePath 'File
ghcPath    :: !( AbsolutePath File )
           , Compiler -> AbsolutePath 'File
ghcPkgPath :: !( AbsolutePath File )
           }
  deriving stock Int -> Compiler -> ShowS
[Compiler] -> ShowS
Compiler -> String
(Int -> Compiler -> ShowS)
-> (Compiler -> String) -> ([Compiler] -> ShowS) -> Show Compiler
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Compiler -> ShowS
showsPrec :: Int -> Compiler -> ShowS
$cshow :: Compiler -> String
show :: Compiler -> String
$cshowList :: [Compiler] -> ShowS
showList :: [Compiler] -> ShowS
Show

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

-- Cabal Hackage index state


-- | Hackage index-state specification, e.g. 2022-12-25T00:00:00Z.

newtype IndexState = IndexState Text
  deriving newtype ( Int -> IndexState -> ShowS
[IndexState] -> ShowS
IndexState -> String
(Int -> IndexState -> ShowS)
-> (IndexState -> String)
-> ([IndexState] -> ShowS)
-> Show IndexState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IndexState -> ShowS
showsPrec :: Int -> IndexState -> ShowS
$cshow :: IndexState -> String
show :: IndexState -> String
$cshowList :: [IndexState] -> ShowS
showList :: [IndexState] -> ShowS
Show, IndexState -> IndexState -> Bool
(IndexState -> IndexState -> Bool)
-> (IndexState -> IndexState -> Bool) -> Eq IndexState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexState -> IndexState -> Bool
== :: IndexState -> IndexState -> Bool
$c/= :: IndexState -> IndexState -> Bool
/= :: IndexState -> IndexState -> Bool
Eq )

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

-- Directory structure


-- | The directory structure relevant to preparing and carrying out

-- a build plan.

type Paths :: PathUsability -> Type
data Paths use
  = Paths
    { forall (use :: PathUsability).
Paths use -> SymbolicPath Project ('Dir Fetch)
fetchDir   :: !( SymbolicPath Project ( Dir Fetch ) )
       -- ^ Input fetched sources directory.

    , forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths :: BuildPaths use
      -- ^ Output build directory structure.

      --

      -- NB: this will be bottom in the case that we are outputing

      -- a shell script that uses variables.

    }

deriving stock instance Show ( BuildPaths use ) => Show ( Paths use )

-- | The directory structure relevant to executing a build plan.

type BuildPaths :: PathUsability -> Type
data family BuildPaths use
data instance BuildPaths Raw
  = RawBuildPaths
    { BuildPaths 'Raw -> SymbolicPath Project ('Dir Install)
rawDestDir :: !( SymbolicPath Project ( Dir Install ) )
      -- ^ Raw output build @destdir@ (might be relative).

    , BuildPaths 'Raw -> SymbolicPath Project ('Dir Prefix)
rawPrefix  :: !( SymbolicPath Project ( Dir Prefix ) )
      -- ^ Raw output build @prefix@ (might be relative).

    }
  deriving stock Int -> BuildPaths 'Raw -> ShowS
[BuildPaths 'Raw] -> ShowS
BuildPaths 'Raw -> String
(Int -> BuildPaths 'Raw -> ShowS)
-> (BuildPaths 'Raw -> String)
-> ([BuildPaths 'Raw] -> ShowS)
-> Show (BuildPaths 'Raw)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildPaths 'Raw -> ShowS
showsPrec :: Int -> BuildPaths 'Raw -> ShowS
$cshow :: BuildPaths 'Raw -> String
show :: BuildPaths 'Raw -> String
$cshowList :: [BuildPaths 'Raw] -> ShowS
showList :: [BuildPaths 'Raw] -> ShowS
Show
data instance BuildPaths ForPrep
  = BuildPathsForPrep
    { BuildPaths 'ForPrep -> Compiler
compilerForPrep :: !Compiler
      -- ^ Which @ghc@ and @ghc-pkg@ to use.

    , BuildPaths 'ForPrep -> AbsolutePath ('Dir Install)
installDir      :: !( AbsolutePath ( Dir Install ) )
      -- ^ Output installation directory @destdir/prefix@ (absolute).

    }
  deriving stock Int -> BuildPaths 'ForPrep -> ShowS
[BuildPaths 'ForPrep] -> ShowS
BuildPaths 'ForPrep -> String
(Int -> BuildPaths 'ForPrep -> ShowS)
-> (BuildPaths 'ForPrep -> String)
-> ([BuildPaths 'ForPrep] -> ShowS)
-> Show (BuildPaths 'ForPrep)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildPaths 'ForPrep -> ShowS
showsPrec :: Int -> BuildPaths 'ForPrep -> ShowS
$cshow :: BuildPaths 'ForPrep -> String
show :: BuildPaths 'ForPrep -> String
$cshowList :: [BuildPaths 'ForPrep] -> ShowS
showList :: [BuildPaths 'ForPrep] -> ShowS
Show
data instance BuildPaths ForBuild
  = BuildPaths
    { BuildPaths 'ForBuild -> Compiler
compiler   :: !Compiler
      -- ^ Which @ghc@ and @ghc-pkg@ to use.

    , BuildPaths 'ForBuild -> AbsolutePath ('Dir Prefix)
prefix     :: !( AbsolutePath ( Dir Prefix ) )
      -- ^ Output build @prefix@ (absolute).

    , BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir :: !( AbsolutePath ( Dir Install ) )
      -- ^ Output installation directory @destdir/prefix@ (absolute).

    , BuildPaths 'ForBuild -> AbsolutePath ('Dir Logs)
logDir     :: !( AbsolutePath ( Dir Logs ) )
      -- ^ Directory in which to put logs.

    }
  deriving stock Int -> BuildPaths 'ForBuild -> ShowS
[BuildPaths 'ForBuild] -> ShowS
BuildPaths 'ForBuild -> String
(Int -> BuildPaths 'ForBuild -> ShowS)
-> (BuildPaths 'ForBuild -> String)
-> ([BuildPaths 'ForBuild] -> ShowS)
-> Show (BuildPaths 'ForBuild)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildPaths 'ForBuild -> ShowS
showsPrec :: Int -> BuildPaths 'ForBuild -> ShowS
$cshow :: BuildPaths 'ForBuild -> String
show :: BuildPaths 'ForBuild -> String
$cshowList :: [BuildPaths 'ForBuild] -> ShowS
showList :: [BuildPaths 'ForBuild] -> ShowS
Show

-- | The appropriate stage at which to use a filepath.

data PathUsability
  -- | We have just parsed filepaths. They need to be canonicalised

  -- before they can be used.

  = Raw
  -- | The filepaths have been canonicalised.

  --

  -- They are now suitable for preparatory build instructions,

  -- but not for performing the build.

  | ForPrep
  -- | The paths are suitable for performing the build.

  | ForBuild

-- | Canonicalise raw 'Paths', computing the appropriate directory structure

-- for preparing and executing a build, respectively.

canonicalizePaths :: Compiler
                  -> BuildStrategy
                  -> SymbolicPath CWD ( Dir Project)
                  -> Paths Raw
                  -> IO ( Paths ForPrep, Paths ForBuild )
canonicalizePaths :: Compiler
-> BuildStrategy
-> SymbolicPath CWD ('Dir Project)
-> Paths 'Raw
-> IO (Paths 'ForPrep, Paths 'ForBuild)
canonicalizePaths Compiler
compiler BuildStrategy
buildStrat SymbolicPath CWD ('Dir Project)
workDir
  ( Paths
    { $sel:fetchDir:Paths :: forall (use :: PathUsability).
Paths use -> SymbolicPath Project ('Dir Fetch)
fetchDir   = SymbolicPath Project ('Dir Fetch)
fetchDir
    , $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = RawBuildPaths { SymbolicPath Project ('Dir Prefix)
$sel:rawPrefix:RawBuildPaths :: BuildPaths 'Raw -> SymbolicPath Project ('Dir Prefix)
rawPrefix :: SymbolicPath Project ('Dir Prefix)
rawPrefix, SymbolicPath Project ('Dir Install)
$sel:rawDestDir:RawBuildPaths :: BuildPaths 'Raw -> SymbolicPath Project ('Dir Install)
rawDestDir :: SymbolicPath Project ('Dir Install)
rawDestDir } } )
  = do
      AbsolutePath ('Dir Prefix)
prefix     <- SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Prefix)
-> IO (AbsolutePath ('Dir Prefix))
forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir Project)
workDir SymbolicPath Project ('Dir Prefix)
rawPrefix
      AbsolutePath ('Dir Install)
installDir <- SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Install)
-> IO (AbsolutePath ('Dir Install))
forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir Project)
workDir ( SymbolicPath Project ('Dir Install)
-> AbsolutePath ('Dir Prefix)
-> SymbolicPath Project ('Dir Install)
mkInstallDir SymbolicPath Project ('Dir Install)
rawDestDir AbsolutePath ('Dir Prefix)
prefix )


      AbsolutePath ('Dir Logs)
logDir <- case BuildStrategy
buildStrat of
        Script  {} -> AbsolutePath ('Dir Logs) -> IO (AbsolutePath ('Dir Logs))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsolutePath ('Dir Logs) -> IO (AbsolutePath ('Dir Logs)))
-> AbsolutePath ('Dir Logs) -> IO (AbsolutePath ('Dir Logs))
forall a b. (a -> b) -> a -> b
$ String -> AbsolutePath ('Dir Logs)
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath String
"${LOGDIR}" -- LOGDIR is defined by the script.

        Execute {} -> do
          -- Pick the logging directory based on the current time.

          UTCTime
time <- IO UTCTime
getCurrentTime
          SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Logs)
-> IO (AbsolutePath ('Dir Logs))
forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir Project)
workDir
            ( String -> SymbolicPath Project ('Dir Logs)
forall from (to :: FileOrDir). String -> SymbolicPath from to
mkSymbolicPath (String -> SymbolicPath Project ('Dir Logs))
-> String -> SymbolicPath Project ('Dir Logs)
forall a b. (a -> b) -> a -> b
$ String
"logs" String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%d_%H-%M-%S" UTCTime
time )

      let forBuild :: Paths 'ForBuild
forBuild = case BuildStrategy
buildStrat of
            Script { Bool
$sel:useVariables:Execute :: BuildStrategy -> Bool
useVariables :: Bool
useVariables }
              | Bool
useVariables
              -> Paths { $sel:fetchDir:Paths :: SymbolicPath Project ('Dir Fetch)
fetchDir   = String -> SymbolicPath Project ('Dir Fetch)
forall from (to :: FileOrDir). String -> SymbolicPath from to
mkSymbolicPath String
"${SOURCES}"
                       , $sel:buildPaths:Paths :: BuildPaths 'ForBuild
buildPaths =
                         BuildPaths
                           { $sel:prefix:BuildPaths :: AbsolutePath ('Dir Prefix)
prefix     = String -> AbsolutePath ('Dir Prefix)
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath String
"${PREFIX}"
                           , $sel:installDir:BuildPaths :: AbsolutePath ('Dir Install)
installDir = String -> AbsolutePath ('Dir Install)
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath (String -> AbsolutePath ('Dir Install))
-> String -> AbsolutePath ('Dir Install)
forall a b. (a -> b) -> a -> b
$ String
"${DESTDIR}" String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"${PREFIX}"
                           , AbsolutePath ('Dir Logs)
$sel:logDir:BuildPaths :: AbsolutePath ('Dir Logs)
logDir :: AbsolutePath ('Dir Logs)
logDir
                           , $sel:compiler:BuildPaths :: Compiler
compiler =
                             Compiler { $sel:ghcPath:Compiler :: AbsolutePath 'File
ghcPath    = String -> AbsolutePath 'File
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath String
"${GHC}"
                                      , $sel:ghcPkgPath:Compiler :: AbsolutePath 'File
ghcPkgPath = String -> AbsolutePath 'File
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath String
"${GHCPKG}" } } }
            BuildStrategy
_don'tUseVars ->
              Paths { SymbolicPath Project ('Dir Fetch)
$sel:fetchDir:Paths :: SymbolicPath Project ('Dir Fetch)
fetchDir :: SymbolicPath Project ('Dir Fetch)
fetchDir
                    , $sel:buildPaths:Paths :: BuildPaths 'ForBuild
buildPaths =
                      BuildPaths { Compiler
$sel:compiler:BuildPaths :: Compiler
compiler :: Compiler
compiler, AbsolutePath ('Dir Prefix)
$sel:prefix:BuildPaths :: AbsolutePath ('Dir Prefix)
prefix :: AbsolutePath ('Dir Prefix)
prefix, AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
installDir, AbsolutePath ('Dir Logs)
$sel:logDir:BuildPaths :: AbsolutePath ('Dir Logs)
logDir :: AbsolutePath ('Dir Logs)
logDir } }
      (Paths 'ForPrep, Paths 'ForBuild)
-> IO (Paths 'ForPrep, Paths 'ForBuild)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Paths 'ForPrep, Paths 'ForBuild)
 -> IO (Paths 'ForPrep, Paths 'ForBuild))
-> (Paths 'ForPrep, Paths 'ForBuild)
-> IO (Paths 'ForPrep, Paths 'ForBuild)
forall a b. (a -> b) -> a -> b
$
        ( Paths { SymbolicPath Project ('Dir Fetch)
$sel:fetchDir:Paths :: SymbolicPath Project ('Dir Fetch)
fetchDir :: SymbolicPath Project ('Dir Fetch)
fetchDir
                , $sel:buildPaths:Paths :: BuildPaths 'ForPrep
buildPaths =
                  BuildPathsForPrep { $sel:compilerForPrep:BuildPathsForPrep :: Compiler
compilerForPrep = Compiler
compiler, AbsolutePath ('Dir Install)
$sel:installDir:BuildPathsForPrep :: AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
installDir } }
        , Paths 'ForBuild
forBuild )

mkInstallDir :: SymbolicPath Project ( Dir Install )
             -> AbsolutePath ( Dir Prefix )
             -> SymbolicPath Project ( Dir Install )
mkInstallDir :: SymbolicPath Project ('Dir Install)
-> AbsolutePath ('Dir Prefix)
-> SymbolicPath Project ('Dir Install)
mkInstallDir SymbolicPath Project ('Dir Install)
destDir AbsolutePath ('Dir Prefix)
prefix =
  SymbolicPath Project ('Dir Install)
destDir SymbolicPath Project ('Dir Install)
-> RelativePath Install ('Dir Install)
-> SymbolicPath Project ('Dir Install)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install ('Dir Install)
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath ( ShowS
dropDrive ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Prefix) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir Prefix)
prefix )
    -- We must use dropDrive here. Quoting from the documentation of (</>):

    --

    --   If the second path starts with a path separator or a drive letter,

    --   then (</>) returns the second path.

    --

    -- We don't want that, as we *do* want to concatenate both paths.


-- | How to handle deletion of temporary directories.

data TempDirPermanence
  = DeleteTempDirs
  | Don'tDeleteTempDirs
  deriving stock Int -> TempDirPermanence -> ShowS
[TempDirPermanence] -> ShowS
TempDirPermanence -> String
(Int -> TempDirPermanence -> ShowS)
-> (TempDirPermanence -> String)
-> ([TempDirPermanence] -> ShowS)
-> Show TempDirPermanence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TempDirPermanence -> ShowS
showsPrec :: Int -> TempDirPermanence -> ShowS
$cshow :: TempDirPermanence -> String
show :: TempDirPermanence -> String
$cshowList :: [TempDirPermanence] -> ShowS
showList :: [TempDirPermanence] -> ShowS
Show

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

-- Verbosity


-- | Verbosity level for the @build-env@ package.

--

-- The default verbosity level is 'Normal' (1).

newtype Verbosity = Verbosity Int
  deriving newtype (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity =>
(Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$c< :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> Verbosity
Ord, Integer -> Verbosity
Verbosity -> Verbosity
Verbosity -> Verbosity -> Verbosity
(Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Integer -> Verbosity)
-> Num Verbosity
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Verbosity -> Verbosity -> Verbosity
+ :: Verbosity -> Verbosity -> Verbosity
$c- :: Verbosity -> Verbosity -> Verbosity
- :: Verbosity -> Verbosity -> Verbosity
$c* :: Verbosity -> Verbosity -> Verbosity
* :: Verbosity -> Verbosity -> Verbosity
$cnegate :: Verbosity -> Verbosity
negate :: Verbosity -> Verbosity
$cabs :: Verbosity -> Verbosity
abs :: Verbosity -> Verbosity
$csignum :: Verbosity -> Verbosity
signum :: Verbosity -> Verbosity
$cfromInteger :: Integer -> Verbosity
fromInteger :: Integer -> Verbosity
Num)
  deriving stock   Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [Verbosity] -> ShowS
Show

-- | Get the flag corresponding to a verbosity, e.g. @-v2@.

verbosityFlag :: Verbosity -> String
verbosityFlag :: Verbosity -> String
verbosityFlag ( Verbosity Int
i )
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  = String
"-v0"
  | Bool
otherwise
  = String
"-v" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i

pattern Quiet, Normal, Verbose, Debug :: Verbosity
pattern $mQuiet :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
$bQuiet :: Verbosity
Quiet   = Verbosity 0
pattern $mNormal :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
$bNormal :: Verbosity
Normal  = Verbosity 1
pattern $mVerbose :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
$bVerbose :: Verbosity
Verbose = Verbosity 2
pattern $mDebug :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
$bDebug :: Verbosity
Debug   = Verbosity 3

quietMsg, normalMsg, verboseMsg, debugMsg :: Verbosity -> Text -> IO ()
quietMsg :: Verbosity -> Text -> IO ()
quietMsg   Verbosity
v Text
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Quiet  ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
normalMsg :: Verbosity -> Text -> IO ()
normalMsg  Verbosity
v Text
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
verboseMsg :: Verbosity -> Text -> IO ()
verboseMsg Verbosity
v Text
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
debugMsg :: Verbosity -> Text -> IO ()
debugMsg   Verbosity
v Text
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Debug  ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg

-- | Write the text to @stdout@, and flush.

putMsg :: Text -> IO ()
putMsg :: Text -> IO ()
putMsg Text
msg = do
  Text -> IO ()
Text.putStrLn Text
msg
  Handle -> IO ()
hFlush Handle
stdout

ghcVerbosity, ghcPkgVerbosity, cabalVerbosity, setupVerbosity
  :: Verbosity -> String
ghcVerbosity :: Verbosity -> String
ghcVerbosity    = Verbosity -> String
verbosityFlag (Verbosity -> String)
-> (Verbosity -> Verbosity) -> Verbosity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
min Verbosity
maxGhcVerbosity    (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity) -> Verbosity -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Num a => a -> a -> a
subtract Verbosity
1
ghcPkgVerbosity :: Verbosity -> String
ghcPkgVerbosity = Verbosity -> String
verbosityFlag (Verbosity -> String)
-> (Verbosity -> Verbosity) -> Verbosity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
min Verbosity
maxGhcPkgVerbosity (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity) -> Verbosity -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Num a => a -> a -> a
subtract Verbosity
1
cabalVerbosity :: Verbosity -> String
cabalVerbosity  = Verbosity -> String
verbosityFlag (Verbosity -> String)
-> (Verbosity -> Verbosity) -> Verbosity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
min Verbosity
maxCabalVerbosity  (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity) -> Verbosity -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Num a => a -> a -> a
subtract Verbosity
1
setupVerbosity :: Verbosity -> String
setupVerbosity  = Verbosity -> String
verbosityFlag (Verbosity -> String)
-> (Verbosity -> Verbosity) -> Verbosity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
min Verbosity
maxSetupVerbosity  (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity) -> Verbosity -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Verbosity
forall a. Num a => a -> a -> a
subtract Verbosity
1

maxGhcVerbosity, maxGhcPkgVerbosity, maxCabalVerbosity, maxSetupVerbosity
  :: Verbosity
maxGhcVerbosity :: Verbosity
maxGhcVerbosity    = Int -> Verbosity
Verbosity Int
3
maxGhcPkgVerbosity :: Verbosity
maxGhcPkgVerbosity = Int -> Verbosity
Verbosity Int
2
maxCabalVerbosity :: Verbosity
maxCabalVerbosity  = Int -> Verbosity
Verbosity Int
3
maxSetupVerbosity :: Verbosity
maxSetupVerbosity  = Verbosity
maxCabalVerbosity

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

-- Reporting progress.


-- | A counter to measure progress, as units are compiled.

data Counter =
  Counter
    { Counter -> IORef Word
counterRef  :: !( IORef Word )
      -- ^ The running count.

    , Counter -> Word
counterMax :: !Word
      -- ^ The maximum that we're counting up to.

    }

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

-- Posix/Windows style differences.


-- | Whether to use Posix or Windows style:

--

--  - for executables, @./prog@ vs @prog.exe@,

--  - for the path separator, @:@ vs @;@.

data Style
  = PosixStyle
  | WinStyle

-- | OS-dependent separator for the PATH environment variable.

pATHSeparator :: Style -> String
pATHSeparator :: Style -> String
pATHSeparator Style
PosixStyle = String
":"
pATHSeparator Style
WinStyle   = String
";"

-- | The style associated with the OS the program is currently running on.

hostStyle :: Style
hostStyle :: Style
hostStyle =
#if defined(mingw32_HOST_OS)
  WinStyle
#else
  Style
PosixStyle
#endif