{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Setup.Installed
( getCompilerVersion
, markInstalled
, unmarkInstalled
, listInstalled
, Tool (..)
, toolString
, toolNameString
, parseToolText
, filterTools
, extraDirs
, installDir
, tempInstallDir
) where
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.Char ( isDigit )
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Distribution.System ( Platform (..) )
import qualified Distribution.System as Cabal
import Path
import Path.IO
import RIO.Process
import Stack.Constants
import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.Config
data Tool
= Tool PackageIdentifier
| ToolGhcGit !Text !Text
deriving (Tool -> Tool -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tool -> Tool -> Bool
$c/= :: Tool -> Tool -> Bool
== :: Tool -> Tool -> Bool
$c== :: Tool -> Tool -> Bool
Eq)
instance Ord Tool where
compare :: Tool -> Tool -> Ordering
compare (Tool PackageIdentifier
pkgId1) (Tool PackageIdentifier
pkgId2) = if PackageName
pkgName1 forall a. Eq a => a -> a -> Bool
== PackageName
pkgName2
then forall a. Ord a => a -> a -> Ordering
compare Version
pkgVersion2 Version
pkgVersion1
else forall a. Ord a => a -> a -> Ordering
compare PackageName
pkgName1 PackageName
pkgName2
where
PackageIdentifier PackageName
pkgName1 Version
pkgVersion1 = PackageIdentifier
pkgId1
PackageIdentifier PackageName
pkgName2 Version
pkgVersion2 = PackageIdentifier
pkgId2
compare (Tool PackageIdentifier
pkgId) (ToolGhcGit Text
_ Text
_) = forall a. Ord a => a -> a -> Ordering
compare (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId) PackageName
"ghc-git"
compare (ToolGhcGit Text
_ Text
_) (Tool PackageIdentifier
pkgId) = forall a. Ord a => a -> a -> Ordering
compare PackageName
"ghc-git" (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId)
compare (ToolGhcGit Text
c1 Text
f1) (ToolGhcGit Text
c2 Text
f2) = if Text
f1 forall a. Eq a => a -> a -> Bool
== Text
f2
then forall a. Ord a => a -> a -> Ordering
compare Text
c1 Text
c2
else forall a. Ord a => a -> a -> Ordering
compare Text
f1 Text
f2
toolString :: Tool -> String
toolString :: Tool -> [Char]
toolString (Tool PackageIdentifier
ident) = PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident
toolString (ToolGhcGit Text
commit Text
flavour) = [Char]
"ghc-git-" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
commit forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
flavour
toolNameString :: Tool -> String
toolNameString :: Tool -> [Char]
toolNameString (Tool PackageIdentifier
ident) = PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident
toolNameString ToolGhcGit{} = [Char]
"ghc-git"
parseToolText :: Text -> Maybe Tool
parseToolText :: Text -> Maybe Tool
parseToolText (Text -> Either PantryException WantedCompiler
parseWantedCompiler -> Right WCGhcjs{}) = forall a. Maybe a
Nothing
parseToolText (Text -> Either PantryException WantedCompiler
parseWantedCompiler -> Right (WCGhcGit Text
c Text
f)) = forall a. a -> Maybe a
Just (Text -> Text -> Tool
ToolGhcGit Text
c Text
f)
parseToolText ([Char] -> Maybe PackageIdentifier
parsePackageIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack -> Just PackageIdentifier
pkgId) = forall a. a -> Maybe a
Just (PackageIdentifier -> Tool
Tool PackageIdentifier
pkgId)
parseToolText Text
_ = forall a. Maybe a
Nothing
markInstalled :: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m ()
markInstalled :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> Tool -> m ()
markInstalled Path Abs Dir
programsPath Tool
tool = do
Path Rel File
fpRel <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool forall a. [a] -> [a] -> [a]
++ [Char]
".installed"
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic (Path Abs Dir
programsPath forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fpRel) Builder
"installed"
unmarkInstalled :: MonadIO m
=> Path Abs Dir
-> Tool
-> m ()
unmarkInstalled :: forall (m :: * -> *). MonadIO m => Path Abs Dir -> Tool -> m ()
unmarkInstalled Path Abs Dir
programsPath Tool
tool = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Path Rel File
fpRel <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool forall a. [a] -> [a] -> [a]
++ [Char]
".installed"
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile forall a b. (a -> b) -> a -> b
$ Path Abs Dir
programsPath forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fpRel)
listInstalled :: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> m [Tool]
listInstalled :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
programsPath = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
programsPath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Bool
True -> do ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
programsPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}. Path b File -> Maybe Tool
toTool [Path Abs File]
files
where
toTool :: Path b File -> Maybe Tool
toTool Path b File
fp = do
Text
x <- Text -> Text -> Maybe Text
T.stripSuffix Text
".installed" forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall b. Path b File -> Path Rel File
filename Path b File
fp
Text -> Maybe Tool
parseToolText Text
x
filterTools :: PackageName
-> (Version -> Bool)
-> [Tool]
-> [PackageIdentifier]
filterTools :: PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools PackageName
name Version -> Bool
goodVersion [Tool]
installed =
[ PackageIdentifier
pkgId | Tool PackageIdentifier
pkgId <- [Tool]
installed
, PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId forall a. Eq a => a -> a -> Bool
== PackageName
name
, Version -> Bool
goodVersion (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkgId) ]
getCompilerVersion
:: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> Path Abs File
-> RIO env ActualCompiler
getCompilerVersion :: forall env.
(HasProcessContext env, HasLogFunc env) =>
WhichCompiler -> Path Abs File -> RIO env ActualCompiler
getCompilerVersion WhichCompiler
wc Path Abs File
exe = do
case WhichCompiler
wc of
WhichCompiler
Ghc -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Asking GHC for its version"
ByteString
bs <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
exe) [[Char]
"--numeric-version"] forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
let (ByteString
_, ByteString
ghcVersion) = ByteString -> (ByteString, ByteString)
versionFromEnd forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
bs
ActualCompiler
x <- Version -> ActualCompiler
ACGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing (Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
ghcVersion)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"GHC version is: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ActualCompiler
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActualCompiler
x
where
versionFromEnd :: ByteString -> (ByteString, ByteString)
versionFromEnd = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S8.spanEnd Char -> Bool
isValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S8.breakEnd Char -> Bool
isValid
isValid :: Char -> Bool
isValid Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
extraDirs :: HasConfig env => Tool -> RIO env ExtraDirs
Tool
tool = do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
Path Abs Dir
dir <- forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
installDir (Config -> Path Abs Dir
configLocalPrograms Config
config) Tool
tool
case (Config -> Platform
configPlatform Config
config, Tool -> [Char]
toolNameString Tool
tool) of
(Platform Arch
_ OS
Cabal.Windows, [Char] -> Bool
isGHC -> Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
{ edBins :: [Path Abs Dir]
edBins =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
}
(Platform Arch
Cabal.I386 OS
Cabal.Windows, [Char]
"msys2") -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
{ edBins :: [Path Abs Dir]
edBins =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw32 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLocal forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
, edInclude :: [Path Abs Dir]
edInclude =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw32 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInclude
]
, edLib :: [Path Abs Dir]
edLib =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw32 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLib
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw32 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
}
(Platform Arch
Cabal.X86_64 OS
Cabal.Windows, [Char]
"msys2") -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
{ edBins :: [Path Abs Dir]
edBins =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw64 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirUsr forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLocal forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
, edInclude :: [Path Abs Dir]
edInclude =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw64 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirInclude
]
, edLib :: [Path Abs Dir]
edLib =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw64 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLib
, Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirMingw64 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
}
(Platform
_, [Char] -> Bool
isGHC -> Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
{ edBins :: [Path Abs Dir]
edBins =
[ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin
]
}
(Platform Arch
_ OS
x, [Char]
toolName) -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"binDirs: unexpected OS/tool combo: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (OS
x, [Char]
toolName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
where
isGHC :: [Char] -> Bool
isGHC [Char]
n = [Char]
"ghc" forall a. Eq a => a -> a -> Bool
== [Char]
n Bool -> Bool -> Bool
|| [Char]
"ghc-" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [Char]
n
installDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m (Path Abs Dir)
installDir :: forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
installDir Path Abs Dir
programsDir Tool
tool = do
Path Rel Dir
relativeDir <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
programsDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relativeDir
tempInstallDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m (Path Abs Dir)
tempInstallDir :: forall env (m :: * -> *).
(MonadReader env m, MonadThrow m) =>
Path Abs Dir -> Tool -> m (Path Abs Dir)
tempInstallDir Path Abs Dir
programsDir Tool
tool = do
Path Rel Dir
relativeDir <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir forall a b. (a -> b) -> a -> b
$ Tool -> [Char]
toolString Tool
tool forall a. [a] -> [a] -> [a]
++ [Char]
".temp"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
programsDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relativeDir