{-# 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 -- ^ e.g. ghc-7.8.4, msys2-20150512

    | ToolGhcGit !Text !Text   -- ^ e.g. ghc-git-COMMIT_ID-FLAVOUR

    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)

-- | 'Tool' values are ordered by name (being @ghc-git@, for @ToolGhcGit _ _@)

-- alphabetically and then by version (later versions are ordered before

-- earlier versions, where applicable).

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 -- Later versions ordered first

      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       -- ^ package to find

            -> (Version -> Bool) -- ^ which versions are acceptable

            -> [Tool]            -- ^ tools to filter

            -> [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 -- ^ executable

  -> 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

-- | Binary directories for the given installed package

extraDirs :: HasConfig env => Tool -> RIO env ExtraDirs
extraDirs :: forall env. HasConfig env => Tool -> RIO env ExtraDirs
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