{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds         #-}
{-# 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 ( (</>), filename, parseRelDir, parseRelFile )
import           Path.IO ( doesDirExist, ignoringAbsence, listDir, removeFile )
import           RIO.Process ( HasProcessContext, proc, readProcess_ )
import           Stack.Constants
                   ( relDirBin, relDirInclude, relDirLib, relDirLocal, relDirMingw
                   , relDirMingw32, relDirMingw64, relDirUsr
                   )
import           Stack.Prelude
import           Stack.Types.Compiler
                   ( ActualCompiler (..), WhichCompiler (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ExtraDirs ( ExtraDirs (..) )

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 =
  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 =
  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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ [Char] -> StyleDoc
flow [Char]
"binDirs: unexpected OS/tool combo:"
        , [Char] -> StyleDoc
flow (forall a. Show a => a -> [Char]
show (OS
x, [Char]
toolName) forall a. Semigroup a => a -> a -> a
<> [Char]
".")
        ]
      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