{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module BuildEnv.Config
(
BuildStrategy(..), RunStrategy(..)
, AsyncSem(..), semDescription
, Args, UnitArgs(..)
, Compiler(..), Cabal(..)
, Paths(..), BuildPaths(..)
, PathUsability(..)
, canonicalizePaths
, TempDirPermanence(..)
, Verbosity(.., Quiet, Normal, Verbose, Debug)
, quietMsg, normalMsg, verboseMsg, debugMsg
, ghcVerbosity, ghcPkgVerbosity, cabalVerbosity, setupVerbosity
, Counter(..)
, Style(..), hostStyle
, pATHSeparator
) where
import Control.Monad
( when )
import Data.Kind
( Type )
import Data.IORef
( IORef )
import Data.Word
( Word16 )
import System.IO
( hFlush, stdout )
import System.Directory
( canonicalizePath )
import System.FilePath
( (</>), dropDrive )
import Data.Text
( Text )
import qualified Data.Text as Text
( pack )
import qualified Data.Text.IO as Text
( putStrLn )
import Data.Time.Clock
( getCurrentTime )
import Data.Time.Format
( defaultTimeLocale, formatTime )
data BuildStrategy
= Execute RunStrategy
| Script
{ BuildStrategy -> String
scriptPath :: !FilePath
, BuildStrategy -> Bool
useVariables :: !Bool
}
deriving stock Int -> BuildStrategy -> ShowS
[BuildStrategy] -> ShowS
BuildStrategy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildStrategy] -> ShowS
$cshowList :: [BuildStrategy] -> ShowS
show :: BuildStrategy -> String
$cshow :: BuildStrategy -> String
showsPrec :: Int -> BuildStrategy -> ShowS
$cshowsPrec :: Int -> BuildStrategy -> ShowS
Show
data RunStrategy
= TopoSort
| Async
AsyncSem
deriving stock Int -> RunStrategy -> ShowS
[RunStrategy] -> ShowS
RunStrategy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunStrategy] -> ShowS
$cshowList :: [RunStrategy] -> ShowS
show :: RunStrategy -> String
$cshow :: RunStrategy -> String
showsPrec :: Int -> RunStrategy -> ShowS
$cshowsPrec :: Int -> RunStrategy -> ShowS
Show
data AsyncSem
= NoSem
| NewQSem !Word16
deriving stock Int -> AsyncSem -> ShowS
[AsyncSem] -> ShowS
AsyncSem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AsyncSem] -> ShowS
$cshowList :: [AsyncSem] -> ShowS
show :: AsyncSem -> String
$cshow :: AsyncSem -> String
showsPrec :: Int -> AsyncSem -> ShowS
$cshowsPrec :: Int -> AsyncSem -> ShowS
Show
semDescription :: AsyncSem -> Text
semDescription :: AsyncSem -> Text
semDescription = \case
AsyncSem
NoSem -> Text
"no semaphore"
NewQSem Word16
i -> Text
"-j" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Word16
i)
type Args = [String]
data UnitArgs =
UnitArgs { UnitArgs -> Args
configureArgs :: !Args
, UnitArgs -> Maybe Args
mbHaddockArgs :: !(Maybe Args)
, UnitArgs -> Args
registerArgs :: !Args
}
deriving stock Int -> UnitArgs -> ShowS
[UnitArgs] -> ShowS
UnitArgs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnitArgs] -> ShowS
$cshowList :: [UnitArgs] -> ShowS
show :: UnitArgs -> String
$cshow :: UnitArgs -> String
showsPrec :: Int -> UnitArgs -> ShowS
$cshowsPrec :: Int -> UnitArgs -> ShowS
Show
data Cabal = Cabal { Cabal -> String
cabalPath :: !FilePath
, Cabal -> Args
globalCabalArgs :: !Args
}
deriving stock Int -> Cabal -> ShowS
[Cabal] -> ShowS
Cabal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cabal] -> ShowS
$cshowList :: [Cabal] -> ShowS
show :: Cabal -> String
$cshow :: Cabal -> String
showsPrec :: Int -> Cabal -> ShowS
$cshowsPrec :: Int -> Cabal -> ShowS
Show
data Compiler =
Compiler { Compiler -> String
ghcPath :: !FilePath
, Compiler -> String
ghcPkgPath :: !FilePath
}
deriving stock Int -> Compiler -> ShowS
[Compiler] -> ShowS
Compiler -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Compiler] -> ShowS
$cshowList :: [Compiler] -> ShowS
show :: Compiler -> String
$cshow :: Compiler -> String
showsPrec :: Int -> Compiler -> ShowS
$cshowsPrec :: Int -> Compiler -> ShowS
Show
type Paths :: PathUsability -> Type
data Paths use
= Paths
{ forall (use :: PathUsability). Paths use -> String
fetchDir :: !FilePath
, forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths :: BuildPaths use
}
type BuildPaths :: PathUsability -> Type
data family BuildPaths use
data instance BuildPaths Raw
= RawBuildPaths
{ BuildPaths 'Raw -> String
rawDestDir :: !FilePath
, BuildPaths 'Raw -> String
rawPrefix :: !FilePath
}
data instance BuildPaths ForPrep
= BuildPathsForPrep
{ BuildPaths 'ForPrep -> Compiler
compilerForPrep :: !Compiler
, BuildPaths 'ForPrep -> String
installDir :: !FilePath
}
data instance BuildPaths ForBuild
= BuildPaths
{ BuildPaths 'ForBuild -> Compiler
compiler :: !Compiler
, BuildPaths 'ForBuild -> String
destDir :: !FilePath
, BuildPaths 'ForBuild -> String
prefix :: !FilePath
, BuildPaths 'ForBuild -> String
installDir :: !FilePath
, BuildPaths 'ForBuild -> String
logDir :: !FilePath
}
data PathUsability
= Raw
| ForPrep
| ForBuild
canonicalizePaths :: Compiler
-> BuildStrategy
-> Paths Raw
-> IO ( Paths ForPrep, Paths ForBuild )
canonicalizePaths :: Compiler
-> BuildStrategy
-> Paths 'Raw
-> IO (Paths 'ForPrep, Paths 'ForBuild)
canonicalizePaths Compiler
compiler BuildStrategy
buildStrat
( Paths
{ $sel:fetchDir:Paths :: forall (use :: PathUsability). Paths use -> String
fetchDir = String
fetchDir0
, $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = RawBuildPaths { String
rawPrefix :: String
$sel:rawPrefix:RawBuildPaths :: BuildPaths 'Raw -> String
rawPrefix, String
rawDestDir :: String
$sel:rawDestDir:RawBuildPaths :: BuildPaths 'Raw -> String
rawDestDir } } )
= do
String
fetchDir <- String -> IO String
canonicalizePath String
fetchDir0
String
prefix <- String -> IO String
canonicalizePath String
rawPrefix
String
destDir <- String -> IO String
canonicalizePath String
rawDestDir
String
installDir <- String -> IO String
canonicalizePath ( String
rawDestDir String -> ShowS
</> ShowS
dropDrive String
prefix )
String
logDir <- case BuildStrategy
buildStrat of
Script {} -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"${LOGDIR}"
Execute {} -> do
UTCTime
time <- IO UTCTime
getCurrentTime
let logDir :: String
logDir = String
"logs" String -> ShowS
</> forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%d_%H-%M-%S" UTCTime
time
String -> IO String
canonicalizePath String
logDir
let forBuild :: Paths 'ForBuild
forBuild = case BuildStrategy
buildStrat of
Script { Bool
useVariables :: Bool
$sel:useVariables:Execute :: BuildStrategy -> Bool
useVariables }
| Bool
useVariables
-> Paths { $sel:fetchDir:Paths :: String
fetchDir = String
"${SOURCES}"
, $sel:buildPaths:Paths :: BuildPaths 'ForBuild
buildPaths =
BuildPaths
{ $sel:prefix:BuildPaths :: String
prefix = String
"${PREFIX}"
, $sel:destDir:BuildPaths :: String
destDir = String
"${DESTDIR}"
, $sel:installDir:BuildPaths :: String
installDir = String
"${DESTDIR}" String -> ShowS
</> String
"${PREFIX}"
, String
logDir :: String
$sel:logDir:BuildPaths :: String
logDir
, $sel:compiler:BuildPaths :: Compiler
compiler =
Compiler { $sel:ghcPath:Compiler :: String
ghcPath = String
"${GHC}"
, $sel:ghcPkgPath:Compiler :: String
ghcPkgPath = String
"${GHCPKG}" } } }
BuildStrategy
_don'tUseVars ->
Paths { String
fetchDir :: String
$sel:fetchDir:Paths :: String
fetchDir
, $sel:buildPaths:Paths :: BuildPaths 'ForBuild
buildPaths =
BuildPaths { Compiler
compiler :: Compiler
$sel:compiler:BuildPaths :: Compiler
compiler, String
destDir :: String
$sel:destDir:BuildPaths :: String
destDir, String
prefix :: String
$sel:prefix:BuildPaths :: String
prefix, String
installDir :: String
$sel:installDir:BuildPaths :: String
installDir, String
logDir :: String
$sel:logDir:BuildPaths :: String
logDir } }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
( Paths { String
fetchDir :: String
$sel:fetchDir:Paths :: String
fetchDir
, $sel:buildPaths:Paths :: BuildPaths 'ForPrep
buildPaths =
BuildPathsForPrep { $sel:compilerForPrep:BuildPathsForPrep :: Compiler
compilerForPrep = Compiler
compiler, String
installDir :: String
$sel:installDir:BuildPathsForPrep :: String
installDir } }
, Paths 'ForBuild
forBuild )
data TempDirPermanence
= DeleteTempDirs
| Don'tDeleteTempDirs
deriving stock Int -> TempDirPermanence -> ShowS
[TempDirPermanence] -> ShowS
TempDirPermanence -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TempDirPermanence] -> ShowS
$cshowList :: [TempDirPermanence] -> ShowS
show :: TempDirPermanence -> String
$cshow :: TempDirPermanence -> String
showsPrec :: Int -> TempDirPermanence -> ShowS
$cshowsPrec :: Int -> TempDirPermanence -> ShowS
Show
newtype Verbosity = Verbosity Int
deriving newtype (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq 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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$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
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord, Integer -> Verbosity
Verbosity -> Verbosity
Verbosity -> Verbosity -> Verbosity
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Verbosity
$cfromInteger :: Integer -> Verbosity
signum :: Verbosity -> Verbosity
$csignum :: Verbosity -> Verbosity
abs :: Verbosity -> Verbosity
$cabs :: Verbosity -> Verbosity
negate :: Verbosity -> Verbosity
$cnegate :: Verbosity -> Verbosity
* :: Verbosity -> Verbosity -> Verbosity
$c* :: Verbosity -> Verbosity -> Verbosity
- :: Verbosity -> Verbosity -> Verbosity
$c- :: Verbosity -> Verbosity -> Verbosity
+ :: Verbosity -> Verbosity -> Verbosity
$c+ :: Verbosity -> Verbosity -> Verbosity
Num)
deriving stock Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show
verbosityFlag :: Verbosity -> String
verbosityFlag :: Verbosity -> String
verbosityFlag ( Verbosity Int
i )
| Int
i forall a. Ord a => a -> a -> Bool
<= Int
0
= String
"-v0"
| Bool
otherwise
= String
"-v" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i
pattern Quiet, Normal, Verbose, Debug :: Verbosity
pattern $bQuiet :: Verbosity
$mQuiet :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
Quiet = Verbosity 0
pattern $bNormal :: Verbosity
$mNormal :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
Normal = Verbosity 1
pattern $bVerbose :: Verbosity
$mVerbose :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
Verbose = Verbosity 2
pattern $bDebug :: Verbosity
$mDebug :: forall {r}. Verbosity -> ((# #) -> r) -> ((# #) -> r) -> r
Debug = Verbosity 3
quietMsg, normalMsg, verboseMsg, debugMsg :: Verbosity -> Text -> IO ()
quietMsg :: Verbosity -> Text -> IO ()
quietMsg Verbosity
v Text
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Quiet ) forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
normalMsg :: Verbosity -> Text -> IO ()
normalMsg Verbosity
v Text
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal ) forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
verboseMsg :: Verbosity -> Text -> IO ()
verboseMsg Verbosity
v Text
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose) forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
debugMsg :: Verbosity -> Text -> IO ()
debugMsg Verbosity
v Text
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v forall a. Ord a => a -> a -> Bool
>= Verbosity
Debug ) forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putMsg Text
msg
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Verbosity
maxGhcVerbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Verbosity
1
ghcPkgVerbosity :: Verbosity -> String
ghcPkgVerbosity = Verbosity -> String
verbosityFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Verbosity
maxGhcPkgVerbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Verbosity
1
cabalVerbosity :: Verbosity -> String
cabalVerbosity = Verbosity -> String
verbosityFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Verbosity
maxCabalVerbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Verbosity
1
setupVerbosity :: Verbosity -> String
setupVerbosity = Verbosity -> String
verbosityFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Verbosity
maxSetupVerbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
data Counter =
Counter
{ Counter -> IORef Word
counterRef :: !( IORef Word )
, Counter -> Word
counterMax :: !Word
}
data Style
= PosixStyle
| WinStyle
pATHSeparator :: Style -> String
pATHSeparator :: Style -> String
pATHSeparator Style
PosixStyle = String
":"
pATHSeparator Style
WinStyle = String
";"
hostStyle :: Style
hostStyle :: Style
hostStyle =
#if defined(mingw32_HOST_OS)
WinStyle
#else
Style
PosixStyle
#endif