{-# LANGUAGE CPP                   #-}
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE ViewPatterns          #-}

{-|
Module      : GHCup.Utils
Description : GHCup domain specific utilities
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable

This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
module GHCup.Utils
  ( module GHCup.Utils.Dirs
  , module GHCup.Utils
#if defined(IS_WINDOWS)
  , module GHCup.Prelude.Windows
#else
  , module GHCup.Prelude.Posix
#endif
  )
where


#if defined(IS_WINDOWS)
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.Posix
#endif
import           GHCup.Download
import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.Optics
import           GHCup.Types.JSON               ( )
import           GHCup.Utils.Dirs
import           GHCup.Version
import           GHCup.Prelude
import           GHCup.Prelude.File
import           GHCup.Prelude.Logger.Internal
import           GHCup.Prelude.MegaParsec
import           GHCup.Prelude.Process
import           GHCup.Prelude.String.QQ

import           Codec.Archive           hiding ( Directory )
import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             ( MonadFail )
#endif
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
                                         hiding ( throwM )
import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
import           Data.Char                      ( isHexDigit )
import           Data.Bifunctor                 ( first )
import           Data.ByteString                ( ByteString )
import           Data.Either
import           Data.Foldable
import           Data.List
import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
import           Data.Maybe
import           Data.Text                      ( Text )
import           Data.Versions         hiding   ( patch )
import           GHC.IO.Exception
import           Haskus.Utils.Variant.Excepts
import           Optics
import           Safe
import           System.FilePath
import           System.IO.Error
import           Text.Regex.Posix
import           Text.PrettyPrint.HughesPJClass (prettyShow)
import           URI.ByteString

import qualified Codec.Compression.BZip        as BZip
import qualified Codec.Compression.GZip        as GZip
import qualified Codec.Compression.Lzma        as Lzma
import qualified Data.ByteString.Lazy          as BL
import qualified Data.Map.Strict               as Map
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as E
import qualified Text.Megaparsec               as MP
import qualified Data.List.NonEmpty            as NE
import qualified Streamly.Prelude              as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)


-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XDataKinds
-- >>> :set -XTypeApplications
-- >>> :set -XQuasiQuotes
-- >>> import System.Directory
-- >>> import URI.ByteString
-- >>> import qualified Data.Text as T
-- >>> import GHCup.Prelude
-- >>> import GHCup.Download
-- >>> import GHCup.Version
-- >>> import GHCup.Errors
-- >>> import GHCup.Types
-- >>> import GHCup.Types.Optics
-- >>> import Optics
-- >>> import GHCup.Prelude.Version.QQ
-- >>> import qualified Data.Text.Encoding as E
-- >>> import Control.Monad.Reader
-- >>> import Haskus.Utils.Variant.Excepts
-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
-- >>> dirs' <- getAllDirs
-- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ]
-- >>> let settings = Settings True 0 False Never Curl False GHCupURL True GPGNone False
-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
-- >>> cwd <- getCurrentDirectory
-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref



    ------------------------
    --[ Symlink handling ]--
    ------------------------


-- | Create a relative symlink destination for the binary directory,
-- given a target toolpath.
binarySymLinkDestination :: ( MonadThrow m
                            , MonadIO m
                            )
                         => FilePath -- ^ binary dir
                         -> FilePath -- ^ the full toolpath
                         -> m FilePath
binarySymLinkDestination :: FilePath -> FilePath -> m FilePath
binarySymLinkDestination FilePath
binDir FilePath
toolPath = do
  FilePath
toolPath' <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
toolPath
  FilePath
binDir' <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
binDir
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> FilePath -> FilePath
relativeSymlink FilePath
binDir' FilePath
toolPath')


-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorGHCSymlinks :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
                      , HasLog env
                      , MonadThrow m
                      , MonadFail m
                      , MonadMask m
                      )
                   => GHCTargetVersion
                   -> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks :: GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
_tvVersion :: Version
_tvTarget :: Maybe Text
..} = do
  Dirs {FilePath
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

  [FilePath]
files                         <- Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [FilePath]
 -> Excepts '[NotInstalled] m [FilePath])
-> Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles GHCTargetVersion
tv
  [FilePath]
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
    let f_xyz :: FilePath
f_xyz = FilePath
f FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
_tvVersion) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
    let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
f_xyz
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF)
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
fullF


-- | Removes the set ghc version for the given target, if any.
rmPlainGHC :: ( MonadReader env m
              , HasDirs env
              , HasLog env
              , MonadThrow m
              , MonadFail m
              , MonadIO m
              , MonadMask m
              )
           => Maybe Text -- ^ target
           -> Excepts '[NotInstalled] m ()
rmPlainGHC :: Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC Maybe Text
target = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  Maybe GHCTargetVersion
mtv                           <- m (Maybe GHCTargetVersion)
-> Excepts '[NotInstalled] m (Maybe GHCTargetVersion)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe GHCTargetVersion)
 -> Excepts '[NotInstalled] m (Maybe GHCTargetVersion))
-> m (Maybe GHCTargetVersion)
-> Excepts '[NotInstalled] m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ Maybe Text -> m (Maybe GHCTargetVersion)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
target
  Maybe GHCTargetVersion
-> (GHCTargetVersion -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GHCTargetVersion
mtv ((GHCTargetVersion -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (GHCTargetVersion -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion
tv -> do
    [FilePath]
files <- Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [FilePath]
 -> Excepts '[NotInstalled] m [FilePath])
-> Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles GHCTargetVersion
tv
    [FilePath]
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
      let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
f FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
      m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF)
      m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
fullF
    -- old ghcup
    let hdc_file :: FilePath
hdc_file = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"haddock-ghc" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
hdc_file)
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
hdc_file


-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorGHCSymlinks :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
                      , HasLog env
                      , MonadThrow m
                      , MonadFail m
                      , MonadMask m
                      )
                   => GHCTargetVersion
                   -> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks :: GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
..} = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  (Int
mj, Int
mi) <- Version -> Excepts '[NotInstalled] m (Int, Int)
forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
_tvVersion
  let v' :: Text
v' = Int -> Text
forall a. Integral a => a -> Text
intToText Int
mj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Integral a => a -> Text
intToText Int
mi

  [FilePath]
files                         <- Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [FilePath]
 -> Excepts '[NotInstalled] m [FilePath])
-> Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles GHCTargetVersion
tv
  [FilePath]
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
    let f_xy :: FilePath
f_xy = FilePath
f FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
v' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
    let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
f_xy
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF)
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
fullF


-- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'
-- and 'haskell-language-server-wrapper-1.6.1.0'.
rmMinorHLSSymlinks :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
                      , HasLog env
                      , MonadThrow m
                      , MonadFail m
                      , MonadMask m
                      )
                   => Version
                   -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks :: Version -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks Version
ver = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

  [FilePath]
hlsBins <- Version -> Excepts '[NotInstalled] m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> m [FilePath]
hlsAllBinaries Version
ver
  [FilePath]
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
hlsBins ((FilePath -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
    let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
f
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF)
    -- on unix, this may be either a file (legacy) or a symlink
    -- on windows, this is always a file... hence 'rmFile'
    -- works consistently across platforms
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
fullF

-- | Removes the set HLS version, if any.
rmPlainHLS :: ( MonadReader env m
              , HasDirs env
              , HasLog env
              , MonadThrow m
              , MonadFail m
              , MonadIO m
              , MonadMask m
              )
           => Excepts '[NotInstalled] m ()
rmPlainHLS :: Excepts '[NotInstalled] m ()
rmPlainHLS = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

  -- delete 'haskell-language-server-8.10.7'
  [FilePath]
hlsBins <- ([FilePath] -> [FilePath])
-> Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
f -> Bool -> Bool
not (FilePath
"haskell-language-server-wrapper" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
f) Bool -> Bool -> Bool
&& (Char
'~' Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FilePath
f)))
    (Excepts '[NotInstalled] m [FilePath]
 -> Excepts '[NotInstalled] m [FilePath])
-> Excepts '[NotInstalled] m [FilePath]
-> Excepts '[NotInstalled] m [FilePath]
forall a b. (a -> b) -> a -> b
$ IO [FilePath] -> Excepts '[NotInstalled] m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> Excepts '[NotInstalled] m [FilePath])
-> IO [FilePath] -> Excepts '[NotInstalled] m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
      FilePath
binDir
      (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
  [FilePath]
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
hlsBins ((FilePath -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (FilePath -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
    let fullF :: FilePath
fullF = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
f
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullF)
    if Bool
isWindows
    then m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
fullF
    else m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
fullF

  -- 'haskell-language-server-wrapper'
  let hlswrapper :: FilePath
hlswrapper = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt
  m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
hlswrapper)
  if Bool
isWindows
  then m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
hlswrapper
  else m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
hlswrapper



    -----------------------------------
    --[ Set/Installed introspection ]--
    -----------------------------------


-- | Whether the given GHC versin is installed.
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled :: GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver = do
  GHCupPath
ghcdir <- GHCTargetVersion -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (GHCupPath -> FilePath
fromGHCupPath GHCupPath
ghcdir)


-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled :: GHCTargetVersion -> m Bool
ghcSrcInstalled GHCTargetVersion
ver = do
  GHCupPath
ghcdir <- GHCTargetVersion -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (GHCupPath -> FilePath
fromGHCupPath GHCupPath
ghcdir FilePath -> FilePath -> FilePath
</> FilePath
ghcUpSrcBuiltFile)


-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
       => Maybe Text   -- ^ the target of the GHC version, if any
                       --  (e.g. armv7-unknown-linux-gnueabihf)
       -> m (Maybe GHCTargetVersion)
ghcSet :: Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
mtarget = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let ghc :: FilePath
ghc = FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"ghc" (\Text
t -> Text -> FilePath
T.unpack Text
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-ghc") Maybe Text
mtarget
  let ghcBin :: FilePath
ghcBin = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
ghc FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt

  -- link destination is of the form ../ghc/<ver>/bin/ghc
  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
  IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion)
-> IO (Maybe GHCTargetVersion)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe GHCTargetVersion -> IO (Maybe GHCTargetVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GHCTargetVersion
forall a. Maybe a
Nothing) (IO (Maybe GHCTargetVersion) -> IO (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion) -> IO (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ do
    FilePath
link <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getLinkTarget FilePath
ghcBin
    GHCTargetVersion -> Maybe GHCTargetVersion
forall a. a -> Maybe a
Just (GHCTargetVersion -> Maybe GHCTargetVersion)
-> IO GHCTargetVersion -> IO (Maybe GHCTargetVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO GHCTargetVersion
forall (m :: * -> *).
MonadThrow m =>
FilePath -> m GHCTargetVersion
ghcLinkVersion FilePath
link
 where
  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
  ghcLinkVersion :: FilePath -> m GHCTargetVersion
ghcLinkVersion (FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt -> Text
t) = Either (ParseErrorBundle Text Void) GHCTargetVersion
-> m GHCTargetVersion
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) GHCTargetVersion
 -> m GHCTargetVersion)
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
-> m GHCTargetVersion
forall a b. (a -> b) -> a -> b
$ Parsec Void Text GHCTargetVersion
-> FilePath
-> Text
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text GHCTargetVersion
parser FilePath
"ghcLinkVersion" Text
t
   where
    parser :: Parsec Void Text GHCTargetVersion
parser =
        (do
           Text
_    <- Parsec Void Text FilePath -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text FilePath
ghcSubPath
           FilePath
_    <- Parsec Void Text FilePath
ghcSubPath
           Text
r    <- Parsec Void Text Char -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep
           Text
rest <- Parsec Void Text Text
forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
           Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
r
           GHCTargetVersion
x <- Parsec Void Text GHCTargetVersion
ghcTargetVerP
           Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
           GHCTargetVersion -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
x
         )
        Parsec Void Text GHCTargetVersion
-> Parsec Void Text FilePath -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
        Parsec Void Text GHCTargetVersion
-> Parsec Void Text Text -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec Void Text Text
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
MP.takeRest
        Parsec Void Text GHCTargetVersion
-> ParsecT Void Text Identity ()
-> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof
    ghcSubPath :: Parsec Void Text FilePath
ghcSubPath = Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep Parsec Void Text FilePath
-> Parsec Void Text Text -> Parsec Void Text FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"ghc" Parsec Void Text FilePath
-> Parsec Void Text FilePath -> Parsec Void Text FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep

-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs :: m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do
  GHCupPath
ghcdir <- m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupGHCBaseDir
  [FilePath]
fs     <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ [IOErrorType] -> [FilePath] -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory (GHCupPath -> FilePath
fromGHCupPath GHCupPath
ghcdir)
  [FilePath]
-> (FilePath -> m (Either FilePath GHCTargetVersion))
-> m [Either FilePath GHCTargetVersion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
fs ((FilePath -> m (Either FilePath GHCTargetVersion))
 -> m [Either FilePath GHCTargetVersion])
-> (FilePath -> m (Either FilePath GHCTargetVersion))
-> m [Either FilePath GHCTargetVersion]
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> case FilePath -> Either SomeException GHCTargetVersion
forall (m :: * -> *).
MonadThrow m =>
FilePath -> m GHCTargetVersion
parseGHCupGHCDir FilePath
f of
    Right GHCTargetVersion
r -> Either FilePath GHCTargetVersion
-> m (Either FilePath GHCTargetVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath GHCTargetVersion
 -> m (Either FilePath GHCTargetVersion))
-> Either FilePath GHCTargetVersion
-> m (Either FilePath GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Either FilePath GHCTargetVersion
forall a b. b -> Either a b
Right GHCTargetVersion
r
    Left  SomeException
_ -> Either FilePath GHCTargetVersion
-> m (Either FilePath GHCTargetVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath GHCTargetVersion
 -> m (Either FilePath GHCTargetVersion))
-> Either FilePath GHCTargetVersion
-> m (Either FilePath GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath GHCTargetVersion
forall a b. a -> Either a b
Left FilePath
f


-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
                      , MonadCatch m
                      )
                   => m [Either FilePath Version]
getInstalledCabals :: m [Either FilePath Version]
getInstalledCabals = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [FilePath]
bins   <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^cabal-.*$|] :: ByteString))
  [Either FilePath Version]
vs <- [FilePath]
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
bins ((FilePath -> m (Either FilePath Version))
 -> m [Either FilePath Version])
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> case Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> Maybe FilePath
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
exeExt (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"cabal-" FilePath
f) of
    Just (Right Version
r) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either FilePath Version
forall a b. b -> Either a b
Right Version
r
    Just (Left  ParseErrorBundle Text Void
_) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f
    Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f
  [Either FilePath Version] -> m [Either FilePath Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either FilePath Version] -> m [Either FilePath Version])
-> [Either FilePath Version] -> m [Either FilePath Version]
forall a b. (a -> b) -> a -> b
$ [Either FilePath Version] -> [Either FilePath Version]
forall a. Eq a => [a] -> [a]
nub [Either FilePath Version]
vs


-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: Version -> m Bool
cabalInstalled Version
ver = do
  [Version]
vers <- ([Either FilePath Version] -> [Version])
-> m [Either FilePath Version] -> m [Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either FilePath Version] -> [Version]
forall a b. [Either a b] -> [b]
rights m [Either FilePath Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either FilePath Version]
getInstalledCabals
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers


-- Return the currently set cabal version, if any.
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: m (Maybe Version)
cabalSet = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let cabalbin :: FilePath
cabalbin = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"cabal" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt

  IOErrorType
-> (IOException -> m (Maybe Version))
-> m (Maybe Version)
-> m (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (m (Maybe Version) -> m (Maybe Version))
-> m (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
isBrokenSymlink FilePath
cabalbin
    if Bool
broken
      then Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
      else do
        Either SomeException FilePath
link <- IO (Either SomeException FilePath)
-> m (Either SomeException FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO (Either SomeException FilePath)
 -> m (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> m (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> IO (Either SomeException FilePath)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InvalidArgument
            (\IOException
e -> Either SomeException FilePath -> IO (Either SomeException FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException FilePath
 -> IO (Either SomeException FilePath))
-> Either SomeException FilePath
-> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException FilePath
forall a b. a -> Either a b
Left (IOException -> SomeException
forall e. Exception e => e -> SomeException
toException IOException
e))
          (IO (Either SomeException FilePath)
 -> IO (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Either SomeException FilePath)
-> IO FilePath -> IO (Either SomeException FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Either SomeException FilePath
forall a b. b -> Either a b
Right (IO FilePath -> IO (Either SomeException FilePath))
-> IO FilePath -> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getLinkTarget FilePath
cabalbin
        case FilePath -> Either SomeException Version
forall (m :: * -> *). MonadThrow m => FilePath -> m Version
linkVersion (FilePath -> Either SomeException Version)
-> Either SomeException FilePath -> Either SomeException Version
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either SomeException FilePath
link of
          Right Version
v -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Version -> m (Maybe Version))
-> Maybe Version -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
          Left SomeException
err -> do
            Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse cabal symlink target with: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
err)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". The symlink "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
cabalbin
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
            Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
 where
  -- We try to be extra permissive with link destination parsing,
  -- because of:
  --   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
  linkVersion :: MonadThrow m => FilePath -> m Version
  linkVersion :: FilePath -> m Version
linkVersion = Either (ParseErrorBundle Text Void) Version -> m Version
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) Version -> m Version)
-> (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> FilePath
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Version
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser FilePath
"linkVersion" (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt

  parser :: Parsec Void Text Version
parser
    =   Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripAbsolutePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
    Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripRelativePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
    Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version
cabalParse
  -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
  cabalParse :: Parsec Void Text Version
cabalParse = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"cabal-" Parsec Void Text Text
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
version'
  -- parses any path component ending with path separator,
  -- e.g. "foo/"
  stripPathComponet :: Parsec Void Text FilePath
stripPathComponet = Parsec Void Text Char -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep Parsec Void Text Text
-> Parsec Void Text FilePath -> Parsec Void Text FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
  -- parses an absolute path up until the last path separator,
  -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
  stripAbsolutePath :: ParsecT Void Text Identity [FilePath]
stripAbsolutePath = Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep Parsec Void Text FilePath
-> ParsecT Void Text Identity [FilePath]
-> ParsecT Void Text Identity [FilePath]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)
  -- parses a relative path up until the last path separator,
  -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
  stripRelativePath :: ParsecT Void Text Identity [FilePath]
stripRelativePath = Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)



-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
-- as well as @~\/.ghcup\/hls\/<\hlsver\>@
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
                 => m [Either FilePath Version]
getInstalledHLSs :: m [Either FilePath Version]
getInstalledHLSs = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [FilePath]
bins                          <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                   ExecOption
execBlank
                   ([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
    )
  [Either FilePath Version]
legacy <- [FilePath]
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
bins ((FilePath -> m (Either FilePath Version))
 -> m [Either FilePath Version])
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall a b. (a -> b) -> a -> b
$ \FilePath
f ->
    case
          Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> Maybe FilePath
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
exeExt (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"haskell-language-server-wrapper-" FilePath
f)
      of
        Just (Right Version
r) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either FilePath Version
forall a b. b -> Either a b
Right Version
r
        Just (Left  ParseErrorBundle Text Void
_) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f
        Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f

  GHCupPath
hlsdir <- m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupHLSBaseDir
  [FilePath]
fs     <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ [IOErrorType] -> [FilePath] -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory (GHCupPath -> FilePath
fromGHCupPath GHCupPath
hlsdir)
  [Either FilePath Version]
new <- [FilePath]
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
fs ((FilePath -> m (Either FilePath Version))
 -> m [Either FilePath Version])
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> case FilePath -> Either SomeException Version
forall (m :: * -> *). MonadThrow m => FilePath -> m Version
parseGHCupHLSDir FilePath
f of
    Right Version
r -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either FilePath Version
forall a b. b -> Either a b
Right Version
r
    Left  SomeException
_ -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f
  [Either FilePath Version] -> m [Either FilePath Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either FilePath Version] -> [Either FilePath Version]
forall a. Eq a => [a] -> [a]
nub ([Either FilePath Version]
new [Either FilePath Version]
-> [Either FilePath Version] -> [Either FilePath Version]
forall a. Semigroup a => a -> a -> a
<> [Either FilePath Version]
legacy))


-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
                   => m [Either FilePath Version]
getInstalledStacks :: m [Either FilePath Version]
getInstalledStacks = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [FilePath]
bins                          <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                   ExecOption
execBlank
                   ([s|^stack-.*$|] :: ByteString)
    )
  [FilePath]
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
bins ((FilePath -> m (Either FilePath Version))
 -> m [Either FilePath Version])
-> (FilePath -> m (Either FilePath Version))
-> m [Either FilePath Version]
forall a b. (a -> b) -> a -> b
$ \FilePath
f ->
    case Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> Maybe FilePath
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
exeExt (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"stack-" FilePath
f) of
        Just (Right Version
r) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either FilePath Version
forall a b. b -> Either a b
Right Version
r
        Just (Left  ParseErrorBundle Text Void
_) -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f
        Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> Either FilePath Version -> m (Either FilePath Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Version -> m (Either FilePath Version))
-> Either FilePath Version -> m (Either FilePath Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Version
forall a b. a -> Either a b
Left FilePath
f

-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet :: m (Maybe Version)
stackSet = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let stackBin :: FilePath
stackBin = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"stack" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt

  IOErrorType
-> (IOException -> m (Maybe Version))
-> m (Maybe Version)
-> m (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (m (Maybe Version) -> m (Maybe Version))
-> m (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
isBrokenSymlink FilePath
stackBin
    if Bool
broken
      then Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
      else do
        Either SomeException FilePath
link <- IO (Either SomeException FilePath)
-> m (Either SomeException FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO (Either SomeException FilePath)
 -> m (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> m (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> IO (Either SomeException FilePath)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InvalidArgument
            (\IOException
e -> Either SomeException FilePath -> IO (Either SomeException FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException FilePath
 -> IO (Either SomeException FilePath))
-> Either SomeException FilePath
-> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException FilePath
forall a b. a -> Either a b
Left (IOException -> SomeException
forall e. Exception e => e -> SomeException
toException IOException
e))
          (IO (Either SomeException FilePath)
 -> IO (Either SomeException FilePath))
-> IO (Either SomeException FilePath)
-> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Either SomeException FilePath)
-> IO FilePath -> IO (Either SomeException FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Either SomeException FilePath
forall a b. b -> Either a b
Right (IO FilePath -> IO (Either SomeException FilePath))
-> IO FilePath -> IO (Either SomeException FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getLinkTarget FilePath
stackBin
        case FilePath -> Either SomeException Version
forall (m :: * -> *). MonadThrow m => FilePath -> m Version
linkVersion (FilePath -> Either SomeException Version)
-> Either SomeException FilePath -> Either SomeException Version
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either SomeException FilePath
link of
          Right Version
v -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Version -> m (Maybe Version))
-> Maybe Version -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
          Left SomeException
err -> do
            Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse stack symlink target with: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
err)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". The symlink "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
stackBin
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" needs to point to valid stack binary, such as 'stack-2.7.1'."
            Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
 where
  linkVersion :: MonadThrow m => FilePath -> m Version
  linkVersion :: FilePath -> m Version
linkVersion = Either (ParseErrorBundle Text Void) Version -> m Version
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) Version -> m Version)
-> (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> FilePath
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Version
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser FilePath
"" (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt
   where
    parser :: Parsec Void Text Version
parser
      =   Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripAbsolutePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripRelativePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version
cabalParse
    -- parses the version of "stack-2.7.1" -> "2.7.1"
    cabalParse :: Parsec Void Text Version
cabalParse = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"stack-" Parsec Void Text Text
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
version'
    -- parses any path component ending with path separator,
    -- e.g. "foo/"
    stripPathComponet :: Parsec Void Text FilePath
stripPathComponet = Parsec Void Text Char -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep Parsec Void Text Text
-> Parsec Void Text FilePath -> Parsec Void Text FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
    -- parses an absolute path up until the last path separator,
    -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
    stripAbsolutePath :: ParsecT Void Text Identity [FilePath]
stripAbsolutePath = Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep Parsec Void Text FilePath
-> ParsecT Void Text Identity [FilePath]
-> ParsecT Void Text Identity [FilePath]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)
    -- parses a relative path up until the last path separator,
    -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
    stripRelativePath :: ParsecT Void Text Identity [FilePath]
stripRelativePath = Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)

-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
stackInstalled :: Version -> m Bool
stackInstalled Version
ver = do
  [Version]
vers <- ([Either FilePath Version] -> [Version])
-> m [Either FilePath Version] -> m [Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either FilePath Version] -> [Version]
forall a b. [Either a b] -> [b]
rights m [Either FilePath Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either FilePath Version]
getInstalledStacks
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers

-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
hlsInstalled :: Version -> m Bool
hlsInstalled Version
ver = do
  [Version]
vers <- ([Either FilePath Version] -> [Version])
-> m [Either FilePath Version] -> m [Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either FilePath Version] -> [Version]
forall a b. [Either a b] -> [b]
rights m [Either FilePath Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either FilePath Version]
getInstalledHLSs
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers

isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
isLegacyHLS :: Version -> m Bool
isLegacyHLS Version
ver = do
  GHCupPath
bdir <- Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
bdir)


-- Return the currently set hls version, if any.
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet :: m (Maybe Version)
hlsSet = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let hlsBin :: FilePath
hlsBin = FilePath
binDir FilePath -> FilePath -> FilePath
</> FilePath
"haskell-language-server-wrapper" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeExt

  IO (Maybe Version) -> m (Maybe Version)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Maybe Version))
-> IO (Maybe Version)
-> IO (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> IO (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- FilePath -> IO Bool
isBrokenSymlink FilePath
hlsBin
    if Bool
broken
      then Maybe Version -> IO (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
      else do
        FilePath
link <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getLinkTarget FilePath
hlsBin
        Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> IO Version -> IO (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Version
forall (m :: * -> *). MonadThrow m => FilePath -> m Version
linkVersion FilePath
link
 where
  linkVersion :: MonadThrow m => FilePath -> m Version
  linkVersion :: FilePath -> m Version
linkVersion = Either (ParseErrorBundle Text Void) Version -> m Version
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) Version -> m Version)
-> (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> FilePath
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Version
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser FilePath
"" (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt
   where
    parser :: Parsec Void Text Version
parser
      =   Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripAbsolutePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version -> Parsec Void Text Version
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [FilePath]
stripRelativePath ParsecT Void Text Identity [FilePath]
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version
cabalParse
    -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
    cabalParse :: Parsec Void Text Version
cabalParse = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-wrapper-" Parsec Void Text Text
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
version'
    -- parses any path component ending with path separator,
    -- e.g. "foo/"
    stripPathComponet :: Parsec Void Text FilePath
stripPathComponet = Parsec Void Text Char -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep Parsec Void Text Text
-> Parsec Void Text FilePath -> Parsec Void Text FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
    -- parses an absolute path up until the last path separator,
    -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
    stripAbsolutePath :: ParsecT Void Text Identity [FilePath]
stripAbsolutePath = Parsec Void Text Char -> Parsec Void Text FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep Parsec Void Text FilePath
-> ParsecT Void Text Identity [FilePath]
-> ParsecT Void Text Identity [FilePath]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)
    -- parses a relative path up until the last path separator,
    -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
    stripRelativePath :: ParsecT Void Text Identity [FilePath]
stripRelativePath = Parsec Void Text FilePath -> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text FilePath -> Parsec Void Text FilePath
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text FilePath
stripPathComponet)


-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader env m
                  , HasDirs env
                  , MonadIO m
                  , MonadThrow m
                  , MonadCatch m
                  )
               => m [Version]
hlsGHCVersions :: m [Version]
hlsGHCVersions = do
  Maybe Version
h <- m (Maybe Version)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m (Maybe Version)
hlsSet
  [Version] -> Maybe [Version] -> [Version]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Version] -> [Version])
-> m (Maybe [Version]) -> m [Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version -> (Version -> m [Version]) -> m (Maybe [Version])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Version
h Version -> m [Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
Version -> m [Version]
hlsGHCVersions'


hlsGHCVersions' :: ( MonadReader env m
                   , HasDirs env
                   , MonadIO m
                   , MonadThrow m
                   , MonadCatch m
                   )
                => Version
                -> m [Version]
hlsGHCVersions' :: Version -> m [Version]
hlsGHCVersions' Version
v' = do
  [FilePath]
bins <- Version -> Maybe Version -> m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [FilePath]
hlsServerBinaries Version
v' Maybe Version
forall a. Maybe a
Nothing
  let vers :: [Either (ParseErrorBundle Text Void) Version]
vers = (FilePath -> Either (ParseErrorBundle Text Void) Version)
-> [FilePath] -> [Either (ParseErrorBundle Text Void) Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Text -> Either (ParseErrorBundle Text Void) Version
version
          (Text -> Either (ParseErrorBundle Text Void) Version)
-> (FilePath -> Text)
-> FilePath
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
          (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust
          (Maybe FilePath -> FilePath)
-> (FilePath -> Maybe FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"haskell-language-server-"
          (FilePath -> Maybe FilePath)
-> (FilePath -> FilePath) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. [a] -> a
head
          ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"~"
          )
        [FilePath]
bins
  [Version] -> m [Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Version] -> m [Version])
-> ([Either (ParseErrorBundle Text Void) Version] -> [Version])
-> [Either (ParseErrorBundle Text Void) Version]
-> m [Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Version -> Ordering) -> [Version] -> [Version]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Version -> Version -> Ordering) -> Version -> Version -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) ([Version] -> [Version])
-> ([Either (ParseErrorBundle Text Void) Version] -> [Version])
-> [Either (ParseErrorBundle Text Void) Version]
-> [Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either (ParseErrorBundle Text Void) Version] -> [Version]
forall a b. [Either a b] -> [b]
rights ([Either (ParseErrorBundle Text Void) Version] -> m [Version])
-> [Either (ParseErrorBundle Text Void) Version] -> m [Version]
forall a b. (a -> b) -> a -> b
$ [Either (ParseErrorBundle Text Void) Version]
vers


-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
                  => Version
                  -> Maybe Version   -- ^ optional GHC version
                  -> m [FilePath]
hlsServerBinaries :: Version -> Maybe Version -> m [FilePath]
hlsServerBinaries Version
ver Maybe Version
mghcVer = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
      CompOption
compExtended
      ExecOption
execBlank
      ([s|^haskell-language-server-|]
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (Version -> ByteString) -> Maybe Version -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [s|.*|] Version -> ByteString
escapeVerRex Maybe Version
mghcVer
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [s|~|]
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack FilePath
exeExt)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
      )
    )

-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
-- Returns the full path.
hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
                          => Version
                          -> Maybe Version   -- ^ optional GHC version
                          -> m [FilePath]
hlsInternalServerScripts :: Version -> Maybe Version -> m [FilePath]
hlsInternalServerScripts Version
ver Maybe Version
mghcVer = do
  GHCupPath
dir <- Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let bdir :: FilePath
bdir = GHCupPath -> FilePath
fromGHCupPath GHCupPath
dir FilePath -> FilePath -> FilePath
</> FilePath
"bin"
  (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
bdir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
f -> Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> (FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
gv)) FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
f) Maybe Version
mghcVer)
    ([FilePath] -> [FilePath]) -> m [FilePath] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
listDirectory FilePath
bdir)

-- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.
-- Returns the full path.
hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
                          => Version
                          -> Maybe Version   -- ^ optional GHC version
                          -> m [FilePath]
hlsInternalServerBinaries :: Version -> Maybe Version -> m [FilePath]
hlsInternalServerBinaries Version
ver Maybe Version
mghcVer = do
  FilePath
dir <- GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> m GHCupPath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
regex = CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
  (Just FilePath
bdir) <- ([FilePath] -> Maybe FilePath)
-> m [FilePath] -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
headMay (m [FilePath] -> m (Maybe FilePath))
-> m [FilePath] -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ [Either FilePath Regex] -> IO [FilePath]
expandFilePath [FilePath -> Either FilePath Regex
forall a b. a -> Either a b
Left (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"lib"), Regex -> Either FilePath Regex
forall a b. b -> Either a b
Right Regex
regex, FilePath -> Either FilePath Regex
forall a b. a -> Either a b
Left FilePath
"bin"]
  (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
bdir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
f -> Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> (FilePath
"-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
gv)) FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
f) Maybe Version
mghcVer)
    ([FilePath] -> [FilePath]) -> m [FilePath] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
listDirectory FilePath
bdir)

-- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/
-- directory, if any.
-- Returns the full path.
hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
                      => Version
                      -> Version   -- ^ GHC version
                      -> m [FilePath]
hlsInternalServerLibs :: Version -> Version -> m [FilePath]
hlsInternalServerLibs Version
ver Version
ghcVer = do
  FilePath
dir <- GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> m GHCupPath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
regex = CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
  (Just FilePath
bdir) <- ([FilePath] -> Maybe FilePath)
-> m [FilePath] -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
headMay (m [FilePath] -> m (Maybe FilePath))
-> m [FilePath] -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ [Either FilePath Regex] -> IO [FilePath]
expandFilePath [FilePath -> Either FilePath Regex
forall a b. a -> Either a b
Left (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"lib"), Regex -> Either FilePath Regex
forall a b. b -> Either a b
Right Regex
regex, FilePath -> Either FilePath Regex
forall a b. a -> Either a b
Left (FilePath
"lib" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (Version -> Text
prettyVer Version
ghcVer))]
  (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
bdir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath]) -> m [FilePath] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
listDirectory FilePath
bdir)


-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
                 => Version
                 -> m (Maybe FilePath)
hlsWrapperBinary :: Version -> m (Maybe FilePath)
hlsWrapperBinary Version
ver = do
  Dirs {FilePath
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [FilePath]
wrapper <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
      CompOption
compExtended
      ExecOption
execBlank
      ([s|^haskell-language-server-wrapper-|] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack FilePath
exeExt) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
      )
    )
  case [FilePath]
wrapper of
    []  -> Maybe FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
    [FilePath
x] -> Maybe FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> m (Maybe FilePath))
-> Maybe FilePath -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x
    [FilePath]
_   -> UnexpectedListLength -> m (Maybe FilePath)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedListLength -> m (Maybe FilePath))
-> UnexpectedListLength -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> UnexpectedListLength
UnexpectedListLength
      FilePath
"There were multiple hls wrapper binaries for a single version"


-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries :: Version -> m [FilePath]
hlsAllBinaries Version
ver = do
  [FilePath]
hls     <- Version -> Maybe Version -> m [FilePath]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [FilePath]
hlsServerBinaries Version
ver Maybe Version
forall a. Maybe a
Nothing
  Maybe FilePath
wrapper <- Version -> m (Maybe FilePath)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe FilePath)
hlsWrapperBinary Version
ver
  [FilePath] -> m [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
wrapper [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
hls)





    -----------------------------------------
    --[ Major version introspection (X.Y) ]--
    -----------------------------------------


-- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV :: Version -> m (Int, Int)
getMajorMinorV Version {[VChunk]
Maybe Word
Maybe Text
NonEmpty VChunk
_vEpoch :: Version -> Maybe Word
_vChunks :: Version -> NonEmpty VChunk
_vRel :: Version -> [VChunk]
_vMeta :: Version -> Maybe Text
_vMeta :: Maybe Text
_vRel :: [VChunk]
_vChunks :: NonEmpty VChunk
_vEpoch :: Maybe Word
..} = case NonEmpty VChunk
_vChunks of
  ((Digits Word
x :| []) :| ((Digits Word
y :| []):[VChunk]
_)) -> (Int, Int) -> m (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
y)
  NonEmpty VChunk
_ -> ParseError -> m (Int, Int)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m (Int, Int)) -> ParseError -> m (Int, Int)
forall a b. (a -> b) -> a -> b
$ FilePath -> ParseError
ParseError FilePath
"Could not parse X.Y from version"


matchMajor :: Version -> Int -> Int -> Bool
matchMajor :: Version -> Int -> Int -> Bool
matchMajor Version
v' Int
major' Int
minor' = case Version -> Maybe (Int, Int)
forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
v' of
  Just (Int
x, Int
y) -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
major' Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
minor'
  Maybe (Int, Int)
Nothing     -> Bool
False

-- | Match PVP prefix.
--
-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
-- True
-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
-- True
-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
-- False
-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
-- True
matchPVPrefix :: PVP -> PVP -> Bool
matchPVPrefix :: PVP -> PVP -> Bool
matchPVPrefix (PVP -> [Int]
toL -> [Int]
prefix) (PVP -> [Int]
toL -> [Int]
full) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool) -> [Int] -> [Int] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Int]
prefix [Int]
full

toL :: PVP -> [Int]
toL :: PVP -> [Int]
toL (PVP NonEmpty Word
inner) = (Word -> Int) -> [Word] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word] -> [Int]) -> [Word] -> [Int]
forall a b. (a -> b) -> a -> b
$ NonEmpty Word -> [Word]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Word
inner


-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
-- PVP version.
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
             => PVP
             -> Maybe Text -- ^ the target triple
             -> m (Maybe GHCTargetVersion)
getGHCForPVP :: PVP -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForPVP PVP
pvpIn Maybe Text
mt = do
  [GHCTargetVersion]
ghcs <- [Either FilePath GHCTargetVersion] -> [GHCTargetVersion]
forall a b. [Either a b] -> [b]
rights ([Either FilePath GHCTargetVersion] -> [GHCTargetVersion])
-> m [Either FilePath GHCTargetVersion] -> m [GHCTargetVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Either FilePath GHCTargetVersion]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
m [Either FilePath GHCTargetVersion]
getInstalledGHCs
  -- we're permissive here... failed parse just means we have no match anyway
  let ghcs' :: [(PVP, Text, Maybe Text)]
ghcs' = [Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ ((GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
 -> [GHCTargetVersion] -> [Maybe (PVP, Text, Maybe Text)])
-> [GHCTargetVersion]
-> (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [Maybe (PVP, Text, Maybe Text)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [GHCTargetVersion] -> [Maybe (PVP, Text, Maybe Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GHCTargetVersion]
ghcs ((GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
 -> [Maybe (PVP, Text, Maybe Text)])
-> (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [Maybe (PVP, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion{Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
..} -> do
        (PVP
pvp_, Text
rest) <- Version -> Maybe (PVP, Text)
forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP Version
_tvVersion
        (PVP, Text, Maybe Text) -> Maybe (PVP, Text, Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP
pvp_, Text
rest, Maybe Text
_tvTarget)

  PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
forall (m :: * -> *).
MonadThrow m =>
PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP' PVP
pvpIn [(PVP, Text, Maybe Text)]
ghcs' Maybe Text
mt

-- | Like 'getGHCForPVP', except with explicit input parameter.
--
-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
-- "Just 8.8.4"
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
-- "Just 8.10.4"
getGHCForPVP' :: MonadThrow m
             => PVP
             -> [(PVP, Text, Maybe Text)] -- ^ installed GHCs
             -> Maybe Text          -- ^ the target triple
             -> m (Maybe GHCTargetVersion)
getGHCForPVP' :: PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP' PVP
pvpIn [(PVP, Text, Maybe Text)]
ghcs' Maybe Text
mt = do
  let mResult :: Maybe (PVP, Text, Maybe Text)
mResult = [(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text)
forall a. [a] -> Maybe a
lastMay
                  ([(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text))
-> ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [(PVP, Text, Maybe Text)]
-> Maybe (PVP, Text, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PVP, Text, Maybe Text) -> (PVP, Text, Maybe Text) -> Ordering)
-> [(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(PVP
x, Text
_, Maybe Text
_) (PVP
y, Text
_, Maybe Text
_) -> PVP -> PVP -> Ordering
forall a. Ord a => a -> a -> Ordering
compare PVP
x PVP
y)
                  ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [(PVP, Text, Maybe Text)]
-> [(PVP, Text, Maybe Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PVP, Text, Maybe Text) -> Bool)
-> [(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter
                      (\(PVP
pvp_, Text
_, Maybe Text
target) ->
                        Maybe Text
target Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
mt Bool -> Bool -> Bool
&& PVP -> PVP -> Bool
matchPVPrefix PVP
pvp_ PVP
pvpIn
                      )
                  ([(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text))
-> [(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [(PVP, Text, Maybe Text)]
ghcs'
  Maybe (PVP, Text, Maybe Text)
-> ((PVP, Text, Maybe Text) -> m GHCTargetVersion)
-> m (Maybe GHCTargetVersion)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (PVP, Text, Maybe Text)
mResult (((PVP, Text, Maybe Text) -> m GHCTargetVersion)
 -> m (Maybe GHCTargetVersion))
-> ((PVP, Text, Maybe Text) -> m GHCTargetVersion)
-> m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ \(PVP
pvp_, Text
rest, Maybe Text
target) -> do
    Version
ver' <- PVP -> Text -> m Version
forall (m :: * -> *). MonadThrow m => PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest
    GHCTargetVersion -> m GHCTargetVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
target Version
ver')


-- | Get the latest available ghc for the given PVP version, which
-- may only contain parts.
--
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r
-- Just (PVP {_pComponents = 8 :| [10,7]})
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r
-- Just (PVP {_pComponents = 8 :| [8,4]})
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r
-- Just (PVP {_pComponents = 8 :| [8,4]})
getLatestToolFor :: MonadThrow m
                 => Tool
                 -> PVP
                 -> GHCupDownloads
                 -> m (Maybe (PVP, VersionInfo))
getLatestToolFor :: Tool -> PVP -> GHCupDownloads -> m (Maybe (PVP, VersionInfo))
getLatestToolFor Tool
tool PVP
pvpIn GHCupDownloads
dls = do
  let ls :: [(Version, VersionInfo)]
ls = [(Version, VersionInfo)]
-> Maybe [(Version, VersionInfo)] -> [(Version, VersionInfo)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Version, VersionInfo)] -> [(Version, VersionInfo)])
-> Maybe [(Version, VersionInfo)] -> [(Version, VersionInfo)]
forall a b. (a -> b) -> a -> b
$ Optic' An_AffineFold '[] GHCupDownloads [(Version, VersionInfo)]
-> GHCupDownloads -> Maybe [(Version, VersionInfo)]
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
-> Optic' An_AffineFold '[] GHCupDownloads [(Version, VersionInfo)]
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map Version VersionInfo -> [(Version, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to Map Version VersionInfo -> [(Version, VersionInfo)]
forall k a. Map k a -> [(k, a)]
Map.toDescList) GHCupDownloads
dls
  let ps :: [((PVP, Text), VersionInfo)]
ps = [Maybe ((PVP, Text), VersionInfo)] -> [((PVP, Text), VersionInfo)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ((PVP, Text), VersionInfo)]
 -> [((PVP, Text), VersionInfo)])
-> [Maybe ((PVP, Text), VersionInfo)]
-> [((PVP, Text), VersionInfo)]
forall a b. (a -> b) -> a -> b
$ ((Version, VersionInfo) -> Maybe ((PVP, Text), VersionInfo))
-> [(Version, VersionInfo)] -> [Maybe ((PVP, Text), VersionInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Version
v, VersionInfo
vi) -> (,VersionInfo
vi) ((PVP, Text) -> ((PVP, Text), VersionInfo))
-> Maybe (PVP, Text) -> Maybe ((PVP, Text), VersionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> Maybe (PVP, Text)
forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP Version
v) [(Version, VersionInfo)]
ls
  Maybe (PVP, VersionInfo) -> m (Maybe (PVP, VersionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PVP, VersionInfo) -> m (Maybe (PVP, VersionInfo)))
-> ([((PVP, Text), VersionInfo)] -> Maybe (PVP, VersionInfo))
-> [((PVP, Text), VersionInfo)]
-> m (Maybe (PVP, VersionInfo))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((PVP, Text), VersionInfo) -> (PVP, VersionInfo))
-> Maybe ((PVP, Text), VersionInfo) -> Maybe (PVP, VersionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((PVP, Text) -> PVP)
-> ((PVP, Text), VersionInfo) -> (PVP, VersionInfo)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PVP, Text) -> PVP
forall a b. (a, b) -> a
fst) (Maybe ((PVP, Text), VersionInfo) -> Maybe (PVP, VersionInfo))
-> ([((PVP, Text), VersionInfo)]
    -> Maybe ((PVP, Text), VersionInfo))
-> [((PVP, Text), VersionInfo)]
-> Maybe (PVP, VersionInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((PVP, Text), VersionInfo)] -> Maybe ((PVP, Text), VersionInfo)
forall a. [a] -> Maybe a
headMay ([((PVP, Text), VersionInfo)] -> Maybe ((PVP, Text), VersionInfo))
-> ([((PVP, Text), VersionInfo)] -> [((PVP, Text), VersionInfo)])
-> [((PVP, Text), VersionInfo)]
-> Maybe ((PVP, Text), VersionInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((PVP, Text), VersionInfo) -> Bool)
-> [((PVP, Text), VersionInfo)] -> [((PVP, Text), VersionInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((PVP
v, Text
_), VersionInfo
_) -> PVP -> PVP -> Bool
matchPVPrefix PVP
pvpIn PVP
v) ([((PVP, Text), VersionInfo)] -> m (Maybe (PVP, VersionInfo)))
-> [((PVP, Text), VersionInfo)] -> m (Maybe (PVP, VersionInfo))
forall a b. (a -> b) -> a -> b
$ [((PVP, Text), VersionInfo)]
ps





    -----------------
    --[ Unpacking ]--
    -----------------



-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
            => FilePath       -- ^ destination dir
            -> FilePath       -- ^ archive path
            -> Excepts '[UnknownArchive
                        , ArchiveResult
                        ] m ()
unpackToDir :: FilePath
-> FilePath -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir FilePath
dfp FilePath
av = do
  let fn :: FilePath
fn = FilePath -> FilePath
takeFileName FilePath
av
  m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Unpacking: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
dfp

  let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
      untar :: ByteString -> Excepts '[ArchiveResult] m ()
untar = m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM (m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ())
-> (ByteString -> m (Either ArchiveResult ()))
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ArchiveResult ()) -> m (Either ArchiveResult ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ArchiveResult ()) -> m (Either ArchiveResult ()))
-> (ByteString -> IO (Either ArchiveResult ()))
-> ByteString
-> m (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM () -> IO (Either ArchiveResult ())
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM () -> IO (Either ArchiveResult ()))
-> (ByteString -> ArchiveM ())
-> ByteString
-> IO (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString -> ArchiveM ()
unpackToDirLazy FilePath
dfp

      rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
      rf :: FilePath -> Excepts '[ArchiveResult] m ByteString
rf = IO ByteString -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Excepts '[ArchiveResult] m ByteString)
-> (FilePath -> IO ByteString)
-> FilePath
-> Excepts '[ArchiveResult] m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BL.readFile

  -- extract, depending on file extension
  if
    | FilePath
".tar.gz" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
      (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".tar.xz" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> do
      ByteString
filecontents <- Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ByteString
 -> Excepts '[UnknownArchive, ArchiveResult] m ByteString)
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av
      let decompressed :: ByteString
decompressed = DecompressParams -> ByteString -> ByteString
Lzma.decompressWith (DecompressParams
Lzma.defaultDecompressParams { decompressAutoDecoder :: Bool
Lzma.decompressAutoDecoder= Bool
True }) ByteString
filecontents
      Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ()
 -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar ByteString
decompressed
    | FilePath
".tar.bz2" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn ->
      Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".tar" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".zip" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | Bool
otherwise -> UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> UnknownArchive
UnknownArchive FilePath
fn


getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
                => FilePath       -- ^ archive path
                -> Excepts '[UnknownArchive
                            , ArchiveResult
                            ] m [FilePath]
getArchiveFiles :: FilePath -> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
getArchiveFiles FilePath
av = do
  let fn :: FilePath
fn = FilePath -> FilePath
takeFileName FilePath
av

  let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
      entries :: ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries = (([Entry FilePath ByteString] -> [FilePath])
-> Excepts '[ArchiveResult] m [Entry FilePath ByteString]
-> Excepts '[ArchiveResult] m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Entry FilePath ByteString] -> [FilePath])
 -> Excepts '[ArchiveResult] m [Entry FilePath ByteString]
 -> Excepts '[ArchiveResult] m [FilePath])
-> ((Entry FilePath ByteString -> FilePath)
    -> [Entry FilePath ByteString] -> [FilePath])
-> (Entry FilePath ByteString -> FilePath)
-> Excepts '[ArchiveResult] m [Entry FilePath ByteString]
-> Excepts '[ArchiveResult] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry FilePath ByteString -> FilePath)
-> [Entry FilePath ByteString] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Entry FilePath ByteString -> FilePath
forall fp e. Entry fp e -> fp
filepath (Excepts '[ArchiveResult] m [Entry FilePath ByteString]
 -> Excepts '[ArchiveResult] m [FilePath])
-> (ByteString
    -> Excepts '[ArchiveResult] m [Entry FilePath ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ArchiveResult [Entry FilePath ByteString]
-> Excepts '[ArchiveResult] m [Entry FilePath ByteString]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE (Either ArchiveResult [Entry FilePath ByteString]
 -> Excepts '[ArchiveResult] m [Entry FilePath ByteString])
-> (ByteString -> Either ArchiveResult [Entry FilePath ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [Entry FilePath ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ArchiveResult [Entry FilePath ByteString]
readArchiveBSL

      rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
      rf :: FilePath -> Excepts '[ArchiveResult] m ByteString
rf = IO ByteString -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Excepts '[ArchiveResult] m ByteString)
-> (FilePath -> IO ByteString)
-> FilePath
-> Excepts '[ArchiveResult] m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BL.readFile

  -- extract, depending on file extension
  if
    | FilePath
".tar.gz" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
      (ByteString -> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".tar.xz" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> do
      ByteString
filecontents <- Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ByteString
 -> Excepts '[UnknownArchive, ArchiveResult] m ByteString)
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av
      let decompressed :: ByteString
decompressed = DecompressParams -> ByteString -> ByteString
Lzma.decompressWith (DecompressParams
Lzma.defaultDecompressParams { decompressAutoDecoder :: Bool
Lzma.decompressAutoDecoder= Bool
True }) ByteString
filecontents
      Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m [FilePath]
 -> Excepts '[UnknownArchive, ArchiveResult] m [FilePath])
-> Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall a b. (a -> b) -> a -> b
$ ByteString -> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries ByteString
decompressed
    | FilePath
".tar.bz2" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn ->
      Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".tar" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | FilePath
".zip" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fn -> Excepts '[ArchiveResult] m [FilePath]
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries (ByteString -> Excepts '[ArchiveResult] m [FilePath])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> Excepts '[ArchiveResult] m ByteString
rf FilePath
av)
    | Bool
otherwise -> UnknownArchive
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (UnknownArchive
 -> Excepts '[UnknownArchive, ArchiveResult] m [FilePath])
-> UnknownArchive
-> Excepts '[UnknownArchive, ArchiveResult] m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> UnknownArchive
UnknownArchive FilePath
fn


intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
           => GHCupPath       -- ^ unpacked tar dir
           -> TarDir         -- ^ how to descend
           -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir :: GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
bdir TarDir
tardir = case TarDir
tardir of
  RealDir FilePath
pr -> do
    Excepts '[TarDirDoesNotExist] m Bool
-> Excepts '[TarDirDoesNotExist] m ()
-> Excepts '[TarDirDoesNotExist] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool)
-> Excepts '[TarDirDoesNotExist] m Bool
-> Excepts '[TarDirDoesNotExist] m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Excepts '[TarDirDoesNotExist] m Bool
 -> Excepts '[TarDirDoesNotExist] m Bool)
-> (FilePath -> Excepts '[TarDirDoesNotExist] m Bool)
-> FilePath
-> Excepts '[TarDirDoesNotExist] m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Excepts '[TarDirDoesNotExist] m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[TarDirDoesNotExist] m Bool)
-> (FilePath -> IO Bool)
-> FilePath
-> Excepts '[TarDirDoesNotExist] m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Bool
doesDirectoryExist (FilePath -> Excepts '[TarDirDoesNotExist] m Bool)
-> FilePath -> Excepts '[TarDirDoesNotExist] m Bool
forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath (GHCupPath
bdir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
pr))
          (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ())
-> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ()
forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir)
    GHCupPath -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
bdir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
pr)
  RegexDir FilePath
r -> do
    let rs :: [FilePath]
rs = (Char -> Bool) -> FilePath -> [FilePath]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
pathSeparators) FilePath
r
    (GHCupPath
 -> FilePath -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> GHCupPath
-> [FilePath]
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\GHCupPath
y FilePath
x ->
        ((IOException -> Excepts '[TarDirDoesNotExist] m [FilePath])
-> Excepts '[TarDirDoesNotExist] m [FilePath]
-> Excepts '[TarDirDoesNotExist] m [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> Excepts '[TarDirDoesNotExist] m [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Excepts '[TarDirDoesNotExist] m [FilePath]
 -> Excepts '[TarDirDoesNotExist] m [FilePath])
-> (FilePath -> Excepts '[TarDirDoesNotExist] m [FilePath])
-> FilePath
-> Excepts '[TarDirDoesNotExist] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [FilePath] -> Excepts '[TarDirDoesNotExist] m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> Excepts '[TarDirDoesNotExist] m [FilePath])
-> (FilePath -> IO [FilePath])
-> FilePath
-> Excepts '[TarDirDoesNotExist] m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Regex -> IO [FilePath]
findFiles (GHCupPath -> FilePath
fromGHCupPath GHCupPath
y) (Regex -> IO [FilePath])
-> (FilePath -> Regex) -> FilePath -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Regex
regex (FilePath -> Excepts '[TarDirDoesNotExist] m [FilePath])
-> FilePath -> Excepts '[TarDirDoesNotExist] m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
x) Excepts '[TarDirDoesNotExist] m [FilePath]
-> ([FilePath] -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
          []      -> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir
          (FilePath
p : [FilePath]
_) -> GHCupPath -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
y GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
p)) ([FilePath] -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> ([FilePath] -> [FilePath])
-> [FilePath]
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort
      )
      GHCupPath
bdir
      [FilePath]
rs
    where regex :: FilePath -> Regex
regex = CompOption -> ExecOption -> FilePath -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compIgnoreCase ExecOption
execBlank




    ------------
    --[ Tags ]--
    ------------


-- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version.
getTagged :: Tag
          -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged :: Tag -> Fold (Map Version VersionInfo) (Version, VersionInfo)
getTagged Tag
tag =
  (Map Version VersionInfo -> [(Version, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to (Map Version VersionInfo -> [(Version, VersionInfo)]
forall k a. Map k a -> [(k, a)]
Map.toDescList (Map Version VersionInfo -> [(Version, VersionInfo)])
-> (Map Version VersionInfo -> Map Version VersionInfo)
-> Map Version VersionInfo
-> [(Version, VersionInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionInfo -> Bool)
-> Map Version VersionInfo -> Map Version VersionInfo
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viTags :: [Tag]
..} -> Tag
tag Tag -> [Tag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tag]
_viTags))
  Optic
  A_Getter
  '[]
  (Map Version VersionInfo)
  (Map Version VersionInfo)
  [(Version, VersionInfo)]
  [(Version, VersionInfo)]
-> Optic
     A_Fold
     '[]
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
     (Version, VersionInfo)
     (Version, VersionInfo)
-> Fold (Map Version VersionInfo) (Version, VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ([(Version, VersionInfo)] -> [(Version, VersionInfo)])
-> Optic
     A_Fold
     '[]
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
     (Version, VersionInfo)
     (Version, VersionInfo)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding [(Version, VersionInfo)] -> [(Version, VersionInfo)]
forall a. a -> a
id

getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest GHCupDownloads
av Tool
tool = Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
-> GHCupDownloads -> Maybe (Version, VersionInfo)
forall k (is :: [*]) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Fold (Map Version VersionInfo) (Version, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag -> Fold (Map Version VersionInfo) (Version, VersionInfo)
getTagged Tag
Latest) GHCupDownloads
av

getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended GHCupDownloads
av Tool
tool = Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
-> GHCupDownloads -> Maybe (Version, VersionInfo)
forall k (is :: [*]) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Fold (Map Version VersionInfo) (Version, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag -> Fold (Map Version VersionInfo) (Version, VersionInfo)
getTagged Tag
Recommended) GHCupDownloads
av


-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
getLatestBaseVersion GHCupDownloads
av PVP
pvpVer =
  Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
-> GHCupDownloads -> Maybe (Version, VersionInfo)
forall k (is :: [*]) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
GHC Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Fold (Map Version VersionInfo) (Version, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (Version, VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag -> Fold (Map Version VersionInfo) (Version, VersionInfo)
getTagged (PVP -> Tag
Base PVP
pvpVer)) GHCupDownloads
av




    -------------
    --[ Other ]--
    -------------

-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
                  => GHCTargetVersion
                  -> m FilePath
ghcInternalBinDir :: GHCTargetVersion -> m FilePath
ghcInternalBinDir GHCTargetVersion
ver = do
  FilePath
ghcdir <- GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> m GHCupPath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GHCTargetVersion -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
ghcdir FilePath -> FilePath -> FilePath
</> FilePath
"bin")


-- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
--
-- Returns unversioned relative files without extension, e.g.:
--
--   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
             => GHCTargetVersion
             -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles :: GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles GHCTargetVersion
ver = do
  FilePath
bindir <- GHCTargetVersion -> Excepts '[NotInstalled] m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> m FilePath
ghcInternalBinDir GHCTargetVersion
ver

  -- fail if ghc is not installed
  Excepts '[NotInstalled] m Bool
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver)
        (NotInstalled -> Excepts '[NotInstalled] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))

  [FilePath]
files <- IO [FilePath] -> Excepts '[NotInstalled] m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
listDirectory FilePath
bindir IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool)
-> (FilePath -> FilePath) -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
bindir FilePath -> FilePath -> FilePath
</>)))
  [FilePath] -> Excepts '[NotInstalled] m [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(FilePath, FilePath)]] -> [FilePath]
getUniqueTools ([[(FilePath, FilePath)]] -> [FilePath])
-> ([FilePath] -> [[(FilePath, FilePath)]])
-> [FilePath]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [[(FilePath, FilePath)]]
groupToolFiles ([FilePath] -> [[(FilePath, FilePath)]])
-> ([FilePath] -> [FilePath])
-> [FilePath]
-> [[(FilePath, FilePath)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix FilePath
exeExt) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
files)

 where

  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
  groupToolFiles :: [FilePath] -> [[(FilePath, FilePath)]]
groupToolFiles = ((FilePath, FilePath) -> (FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [[(FilePath, FilePath)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(FilePath
a, FilePath
_) (FilePath
b, FilePath
_) -> FilePath
a FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
b) ([(FilePath, FilePath)] -> [[(FilePath, FilePath)]])
-> ([FilePath] -> [(FilePath, FilePath)])
-> [FilePath]
-> [[(FilePath, FilePath)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> (FilePath, FilePath)
splitOnPVP FilePath
"-")

  getUniqueTools :: [[(FilePath, String)]] -> [String]
  getUniqueTools :: [[(FilePath, FilePath)]] -> [FilePath]
getUniqueTools = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ([FilePath] -> FilePath -> Bool
isNotAnyInfix [FilePath]
blackListedTools) ([FilePath] -> [FilePath])
-> ([[(FilePath, FilePath)]] -> [FilePath])
-> [[(FilePath, FilePath)]]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([[(FilePath, FilePath)]] -> [FilePath])
-> [[(FilePath, FilePath)]]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ([(FilePath, FilePath)] -> [FilePath])
-> ([[(FilePath, FilePath)]] -> [(FilePath, FilePath)])
-> [[(FilePath, FilePath)]]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"") (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> ([[(FilePath, FilePath)]] -> [(FilePath, FilePath)])
-> [[(FilePath, FilePath)]]
-> [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(FilePath, FilePath)]] -> [(FilePath, FilePath)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

  blackListedTools :: [String]
  blackListedTools :: [FilePath]
blackListedTools = [FilePath
"haddock-ghc"]

  isNotAnyInfix :: [String] -> String -> Bool
  isNotAnyInfix :: [FilePath] -> FilePath -> Bool
isNotAnyInfix [FilePath]
xs FilePath
t = (FilePath -> Bool -> Bool) -> Bool -> [FilePath] -> Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\FilePath
a Bool
b -> Bool -> Bool
not (FilePath
a FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
t) Bool -> Bool -> Bool
&& Bool
b) Bool
True [FilePath]
xs


-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = FilePath
".ghcup_src_built"


-- | Calls gmake if it exists in PATH, otherwise make.
make :: ( MonadThrow m
        , MonadIO m
        , MonadReader env m
        , HasDirs env
        , HasLog env
        , HasSettings env
        )
     => [String]
     -> Maybe FilePath
     -> m (Either ProcessError ())
make :: [FilePath] -> Maybe FilePath -> m (Either ProcessError ())
make [FilePath]
args Maybe FilePath
workdir = do
  [FilePath]
spaths    <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getSearchPath
  Bool
has_gmake <- Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> m (Maybe FilePath) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath [FilePath]
spaths FilePath
"gmake")
  let mymake :: FilePath
mymake = if Bool
has_gmake then FilePath
"gmake" else FilePath
"make"
  FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
 MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
mymake [FilePath]
args Maybe FilePath
workdir FilePath
"ghc-make" Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing

makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
        => [String]
        -> Maybe FilePath
        -> m CapturedProcess
makeOut :: [FilePath] -> Maybe FilePath -> m CapturedProcess
makeOut [FilePath]
args Maybe FilePath
workdir = do
  [FilePath]
spaths    <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getSearchPath
  Bool
has_gmake <- Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> m (Maybe FilePath) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath [FilePath]
spaths FilePath
"gmake")
  let mymake :: FilePath
mymake = if Bool
has_gmake then FilePath
"gmake" else FilePath
"make"
  FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
forall (m :: * -> *).
MonadIO m =>
FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
executeOut FilePath
mymake [FilePath]
args Maybe FilePath
workdir


-- | Try to apply patches in order. The order is determined by
-- a quilt series file (in the patch directory) if one exists,
-- else the patches are applied in lexicographical order.
-- Fails with 'PatchFailed' on first failure.
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
             => FilePath   -- ^ dir containing patches
             -> FilePath   -- ^ dir to apply patches in
             -> Excepts '[PatchFailed] m ()
applyPatches :: FilePath -> FilePath -> Excepts '[PatchFailed] m ()
applyPatches FilePath
pdir FilePath
ddir = do
  let lexicographical :: IO [FilePath]
lexicographical = (([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath])
-> ((FilePath -> FilePath) -> [FilePath] -> [FilePath])
-> (FilePath -> FilePath)
-> IO [FilePath]
-> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (FilePath
pdir FilePath -> FilePath -> FilePath
</>) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Regex -> IO [FilePath]
findFiles
        FilePath
pdir
        (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                       ExecOption
execBlank
                       ([s|.+\.(patch|diff)$|] :: ByteString)
        )
  let quilt :: IO [FilePath]
quilt = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
pdir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile (FilePath
pdir FilePath -> FilePath -> FilePath
</> FilePath
"series")

  [FilePath]
patches <- IO [FilePath] -> Excepts '[PatchFailed] m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> Excepts '[PatchFailed] m [FilePath])
-> IO [FilePath] -> Excepts '[PatchFailed] m [FilePath]
forall a b. (a -> b) -> a -> b
$ IO [FilePath]
quilt IO [FilePath] -> (IOException -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` (\IOException
e ->
    if IOException -> Bool
isDoesNotExistError IOException
e Bool -> Bool -> Bool
|| IOException -> Bool
isPermissionError IOException
e then
      IO [FilePath]
lexicographical 
    else IOException -> IO [FilePath]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
  [FilePath]
-> (FilePath -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
patches ((FilePath -> Excepts '[PatchFailed] m ())
 -> Excepts '[PatchFailed] m ())
-> (FilePath -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
patch' -> FilePath -> FilePath -> Excepts '[PatchFailed] m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
FilePath -> FilePath -> Excepts '[PatchFailed] m ()
applyPatch FilePath
patch' FilePath
ddir


applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
           => FilePath   -- ^ Patch
           -> FilePath   -- ^ dir to apply patches in
           -> Excepts '[PatchFailed] m ()
applyPatch :: FilePath -> FilePath -> Excepts '[PatchFailed] m ()
applyPatch FilePath
patch FilePath
ddir = do
  m () -> Excepts '[PatchFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[PatchFailed] m ())
-> m () -> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Applying patch " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
patch
  (Either ProcessError () -> Maybe ())
-> m (Either ProcessError ()) -> m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProcessError -> Maybe ())
-> (() -> Maybe ()) -> Either ProcessError () -> Maybe ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe () -> ProcessError -> Maybe ()
forall a b. a -> b -> a
const Maybe ()
forall a. Maybe a
Nothing) () -> Maybe ()
forall a. a -> Maybe a
Just)
       (FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
forall (m :: * -> *).
MonadIO m =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec
         FilePath
"patch"
         [FilePath
"-p1", FilePath
"-s", FilePath
"-f", FilePath
"-i", FilePath
patch]
         (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
ddir)
         Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing)
    m (Maybe ()) -> PatchFailed -> Excepts '[PatchFailed] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Maybe a) -> e -> Excepts es m a
!? PatchFailed
PatchFailed


applyAnyPatch :: ( MonadReader env m
                 , HasDirs env
                 , HasLog env
                 , HasSettings env
                 , MonadUnliftIO m
                 , MonadCatch m
                 , MonadResource m
                 , MonadThrow m
                 , MonadMask m
                 , MonadIO m)
              => Maybe (Either FilePath [URI])
              -> FilePath
              -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
applyAnyPatch :: Maybe (Either FilePath [URI])
-> FilePath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
applyAnyPatch Maybe (Either FilePath [URI])
Nothing FilePath
_                   = ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
applyAnyPatch (Just (Left FilePath
pdir)) FilePath
workdir  = Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[PatchFailed] m ()
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
-> Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Excepts '[PatchFailed] m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
FilePath -> FilePath -> Excepts '[PatchFailed] m ()
applyPatches FilePath
pdir FilePath
workdir
applyAnyPatch (Just (Right [URI]
uris)) FilePath
workdir = do
  FilePath
tmpUnpack <- GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath)
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m GHCupPath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCupPath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m GHCupPath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
 MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
 MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
  [URI]
-> (URI
    -> Excepts
         '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [URI]
uris ((URI
  -> Excepts
       '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
-> (URI
    -> Excepts
         '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall a b. (a -> b) -> a -> b
$ \URI
uri -> do
    FilePath
patch <- Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m FilePath
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, GPGError] m FilePath)
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m FilePath
forall a b. (a -> b) -> a -> b
$ URI
-> Maybe URI
-> Maybe Text
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
 MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
download URI
uri Maybe URI
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing FilePath
tmpUnpack Maybe FilePath
forall a. Maybe a
Nothing Bool
False
    Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[PatchFailed] m ()
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, GPGError] m ())
-> Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Excepts '[PatchFailed] m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
FilePath -> FilePath -> Excepts '[PatchFailed] m ()
applyPatch FilePath
patch FilePath
workdir


-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
                   => Platform
                   -> FilePath
                   -> m (Either ProcessError ())
darwinNotarization :: Platform -> FilePath -> m (Either ProcessError ())
darwinNotarization Platform
Darwin FilePath
path = FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
forall (m :: * -> *).
MonadIO m =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec
  FilePath
"xattr"
  [FilePath
"-r", FilePath
"-d", FilePath
"com.apple.quarantine", FilePath
path]
  Maybe FilePath
forall a. Maybe a
Nothing
  Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
darwinNotarization Platform
_ FilePath
_ = Either ProcessError () -> m (Either ProcessError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessError () -> m (Either ProcessError ()))
-> Either ProcessError () -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ProcessError ()
forall a b. b -> Either a b
Right ()




getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
getChangeLog GHCupDownloads
dls Tool
tool (Left Version
v') =
  Optic' An_AffineTraversal '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     An_AffineTraversal
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map Version VersionInfo)
-> Optic'
     (IxKind (Map Version VersionInfo))
     '[]
     (Map Version VersionInfo)
     (IxValue (Map Version VersionInfo))
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index (Map Version VersionInfo)
Version
v' Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineTraversal '[] GHCupDownloads URI
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (Right Tag
tag) =
  Optic' An_AffineFold '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Version, VersionInfo)
     (Version, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Version, VersionInfo)
     (Version, VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Fold (Map Version VersionInfo) (Version, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Version, VersionInfo)
     (Version, VersionInfo)
forall k (is :: [*]) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre (Tag -> Fold (Map Version VersionInfo) (Version, VersionInfo)
getTagged Tag
tag) Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Version, VersionInfo)
  (Version, VersionInfo)
-> Optic
     A_Getter
     '[]
     (Version, VersionInfo)
     (Version, VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ((Version, VersionInfo) -> VersionInfo)
-> Optic
     A_Getter
     '[]
     (Version, VersionInfo)
     (Version, VersionInfo)
     VersionInfo
     VersionInfo
forall s a. (s -> a) -> Getter s a
to (Version, VersionInfo) -> VersionInfo
forall a b. (a, b) -> b
snd Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineFold '[] GHCupDownloads URI
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls


-- | Execute a build action while potentially cleaning up:
--
--   1. the build directory, depending on the KeepDirs setting
runBuildAction :: ( MonadReader env m
                  , HasDirs env
                  , HasSettings env
                  , MonadIO m
                  , MonadMask m
                  , HasLog env
                  , MonadUnliftIO m
                  , MonadFail m
                  , MonadCatch m
                  )
               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
               -> Excepts e m a
               -> Excepts e m a
runBuildAction :: GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
GPGSetting
Downloader
KeepDirs
URLSource
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaCache :: Integer
cache :: Bool
..} <- m Settings -> Excepts e m Settings
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  a
v <-
    (Excepts e m a -> Excepts e m () -> Excepts e m a)
-> Excepts e m () -> Excepts e m a -> Excepts e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts e m a -> Excepts e m () -> Excepts e m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (m () -> Excepts e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction)
    (Excepts e m a -> Excepts e m a) -> Excepts e m a -> Excepts e m a
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m a -> Excepts e m a
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action
  Bool -> Excepts e m () -> Excepts e m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never Bool -> Bool -> Bool
|| KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Errors) (Excepts e m () -> Excepts e m ())
-> Excepts e m () -> Excepts e m ()
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts e m ()) -> m () -> Excepts e m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  a -> Excepts e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v


-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanUpOnError :: forall e m a env .
                  ( MonadReader env m
                  , HasDirs env
                  , HasSettings env
                  , MonadIO m
                  , MonadMask m
                  , HasLog env
                  , MonadUnliftIO m
                  , MonadFail m
                  , MonadCatch m
                  )
               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
               -> Excepts e m a
               -> Excepts e m a
cleanUpOnError :: GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
GPGSetting
Downloader
KeepDirs
URLSource
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaCache :: Integer
cache :: Bool
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- m Settings -> Excepts e m Settings
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  (Excepts e m a -> Excepts e m () -> Excepts e m a)
-> Excepts e m () -> Excepts e m a -> Excepts e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts e m a -> Excepts e m () -> Excepts e m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (m () -> Excepts e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) (Excepts e m a -> Excepts e m a) -> Excepts e m a -> Excepts e m a
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m a -> Excepts e m a
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action


-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanFinally :: ( MonadReader env m
                  , HasDirs env
                  , HasSettings env
                  , MonadIO m
                  , MonadMask m
                  , HasLog env
                  , MonadUnliftIO m
                  , MonadFail m
                  , MonadCatch m
                  )
               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
               -> Excepts e m a
               -> Excepts e m a
cleanFinally :: GHCupPath -> Excepts e m a -> Excepts e m a
cleanFinally GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
GPGSetting
Downloader
KeepDirs
URLSource
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaCache :: Integer
cache :: Bool
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- m Settings -> Excepts e m Settings
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  (Excepts e m a -> Excepts e m () -> Excepts e m a)
-> Excepts e m () -> Excepts e m a -> Excepts e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts e m a -> Excepts e m () -> Excepts e m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (m () -> Excepts e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) (Excepts e m a -> Excepts e m a) -> Excepts e m a -> Excepts e m a
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m a -> Excepts e m a
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action


-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
rmBDir :: GHCupPath -> m ()
rmBDir GHCupPath
dir = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> m () -> IO ()
forall a. m a -> IO a
run (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$
           IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> m () -> IO ()
forall a. m a -> IO a
run (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
               Text
"Couldn't remove build dir " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dir) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", error was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e))
           (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
           (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmPathForcibly GHCupPath
dir)


getVersionInfo :: Version
               -> Tool
               -> GHCupDownloads
               -> Maybe VersionInfo
getVersionInfo :: Version -> Tool -> GHCupDownloads -> Maybe VersionInfo
getVersionInfo Version
v' Tool
tool =
  Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> GHCupDownloads -> Maybe VersionInfo
forall k (is :: [*]) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf
    ( Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool
    Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Map Version VersionInfo)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Map Version VersionInfo)
     (Map Version VersionInfo)
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map Version VersionInfo -> Map Version VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     (Map Version VersionInfo)
forall s a. (s -> a) -> Getter s a
to ((Version -> VersionInfo -> Bool)
-> Map Version VersionInfo -> Map Version VersionInfo
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Version
k VersionInfo
_ -> Version
k Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
v'))
    Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [VersionInfo]
     [VersionInfo]
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     [VersionInfo]
     [VersionInfo]
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map Version VersionInfo -> [VersionInfo])
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [VersionInfo]
     [VersionInfo]
forall s a. (s -> a) -> Getter s a
to Map Version VersionInfo -> [VersionInfo]
forall k a. Map k a -> [a]
Map.elems
    Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  [VersionInfo]
  [VersionInfo]
-> Optic
     An_AffineTraversal
     '[]
     [VersionInfo]
     [VersionInfo]
     VersionInfo
     VersionInfo
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineTraversal
  '[]
  [VersionInfo]
  [VersionInfo]
  VersionInfo
  VersionInfo
forall s a. Cons s s a a => AffineTraversal' s a
_head
    )


ensureGlobalTools :: ( MonadMask m
                     , MonadThrow m
                     , HasLog env
                     , MonadIO m
                     , MonadReader env m
                     , HasDirs env
                     , HasSettings env
                     , HasGHCupInfo env
                     , MonadUnliftIO m
                     , MonadFail m
                     )
                  => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools :: Excepts '[GPGError, DigestError, DownloadFailed, NoDownload] m ()
ensureGlobalTools
  | Bool
isWindows = do
      (GHCupInfo ToolRequirements
_ GHCupDownloads
_ Map GlobalTool DownloadInfo
gTools) <- m GHCupInfo
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m GHCupInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m GHCupInfo
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
      Dirs
dirs <- m Dirs
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m Dirs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
      DownloadInfo
shimDownload <- Excepts '[NoDownload] m DownloadInfo
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m DownloadInfo
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NoDownload] m DownloadInfo
 -> Excepts
      '[GPGError, DigestError, DownloadFailed, NoDownload]
      m
      DownloadInfo)
-> Excepts '[NoDownload] m DownloadInfo
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m DownloadInfo
forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
forall a (m :: * -> *).
(Monad m, NoDownload :< '[NoDownload]) =>
Either NoDownload a -> Excepts '[NoDownload] m a
lE @_ @'[NoDownload]
        (Either NoDownload DownloadInfo
 -> Excepts '[NoDownload] m DownloadInfo)
-> Either NoDownload DownloadInfo
-> Excepts '[NoDownload] m DownloadInfo
forall a b. (a -> b) -> a -> b
$ Either NoDownload DownloadInfo
-> (DownloadInfo -> Either NoDownload DownloadInfo)
-> Maybe DownloadInfo
-> Either NoDownload DownloadInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NoDownload -> Either NoDownload DownloadInfo
forall a b. a -> Either a b
Left NoDownload
NoDownload) DownloadInfo -> Either NoDownload DownloadInfo
forall a b. b -> Either a b
Right (Maybe DownloadInfo -> Either NoDownload DownloadInfo)
-> Maybe DownloadInfo -> Either NoDownload DownloadInfo
forall a b. (a -> b) -> a -> b
$ GlobalTool -> Map GlobalTool DownloadInfo -> Maybe DownloadInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalTool
ShimGen Map GlobalTool DownloadInfo
gTools
      let dl :: Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
dl = DownloadInfo
-> Maybe FilePath
-> Maybe FilePath
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
 MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe FilePath
-> Maybe FilePath
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
downloadCached' DownloadInfo
shimDownload (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"gs.exe") Maybe FilePath
forall a. Maybe a
Nothing
      Excepts
  '[GPGError, DigestError, DownloadFailed, NoDownload] m FilePath
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Excepts
   '[GPGError, DigestError, DownloadFailed, NoDownload] m FilePath
 -> Excepts
      '[GPGError, DigestError, DownloadFailed, NoDownload] m ())
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m FilePath
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m ()
forall a b. (a -> b) -> a -> b
$ (\DigestError{} -> do
          m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ())
-> m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn Text
"Digest doesn't match, redownloading gs.exe..."
          m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ())
-> m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (GHCupPath -> FilePath
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) FilePath -> FilePath -> FilePath
</> FilePath
"gs.exe"))
          m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ())
-> m () -> Excepts '[GPGError, DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile (GHCupPath -> FilePath
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) FilePath -> FilePath -> FilePath
</> FilePath
"gs.exe")
          forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
forall (es :: [*]) a (m :: * -> *).
(Monad m,
 VEitherLift es '[GPGError, DigestError, DownloadFailed]) =>
Excepts es m a
-> Excepts '[GPGError, DigestError, DownloadFailed] m a
liftE @'[GPGError, DigestError , DownloadFailed] (Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
 -> Excepts '[GPGError, DigestError, DownloadFailed] m FilePath)
-> Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
-> Excepts '[GPGError, DigestError, DownloadFailed] m FilePath
forall a b. (a -> b) -> a -> b
$ Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
dl
        ) (DigestError
 -> Excepts '[GPGError, DigestError, DownloadFailed] m FilePath)
-> Excepts '[GPGError, DigestError, DownloadFailed] m FilePath
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m FilePath
forall e (es' :: [*]) (es'' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es',
 LiftVariant es'' es') =>
(e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a
`catchE` Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
-> Excepts '[GPGError, DigestError, DownloadFailed] m FilePath
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE @'[GPGError, DigestError , DownloadFailed] Excepts '[DigestError, DownloadFailed, GPGError] m FilePath
dl
  | Bool
otherwise = ()
-> Excepts
     '[GPGError, DigestError, DownloadFailed, NoDownload] m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs GHCupPath
baseDir FilePath
binDir GHCupPath
cacheDir GHCupPath
logsDir GHCupPath
confDir GHCupPath
trashDir GHCupPath
dbDir GHCupPath
tmpDir) = do
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
"ghc")
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
"hls")
  FilePath -> IO ()
createDirRecursive' FilePath
binDir
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
cacheDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
logsDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
confDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
trashDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dbDir)
  FilePath -> IO ()
createDirRecursive' (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpDir)
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | For ghc without arch triple, this is:
--
--    - ghc
--
-- For ghc with arch triple:
--
--    - <triple>-ghc (e.g. arm-linux-gnueabihf-ghc)
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName :: GHCTargetVersion -> FilePath
ghcBinaryName (GHCTargetVersion (Just Text
t) Version
_) = Text -> FilePath
T.unpack (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-ghc" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exeExt)
ghcBinaryName (GHCTargetVersion Maybe Text
Nothing  Version
_) = Text -> FilePath
T.unpack (Text
"ghc" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exeExt)


-- | Does basic checks for isolated installs
-- Isolated Directory:
--   1. if it doesn't exist -> proceed
--   2. if it exists and is empty -> proceed
--   3. if it exists and is non-empty -> panic and leave the house
installDestSanityCheck :: ( MonadIO m
                          , MonadCatch m
                          , MonadMask m
                          ) =>
                          InstallDirResolved ->
                          Excepts '[DirNotEmpty] m ()
installDestSanityCheck :: InstallDirResolved -> Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved FilePath
isoDir) = do
  [IOErrorType]
-> () -> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] () (Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ())
-> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
empty' <- IO Bool -> Excepts '[DirNotEmpty] m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[DirNotEmpty] m Bool)
-> IO Bool -> Excepts '[DirNotEmpty] m Bool
forall a b. (a -> b) -> a -> b
$ SerialT IO FilePath -> IO Bool
forall (m :: * -> *) a. Monad m => SerialT m a -> m Bool
S.null (SerialT IO FilePath -> IO Bool) -> SerialT IO FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> SerialT IO FilePath
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
FilePath -> SerialT m FilePath
getDirectoryContentsRecursiveUnsafe FilePath
isoDir
    Bool -> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
empty') (DirNotEmpty -> Excepts '[DirNotEmpty] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (DirNotEmpty -> Excepts '[DirNotEmpty] m ())
-> DirNotEmpty -> Excepts '[DirNotEmpty] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> DirNotEmpty
DirNotEmpty FilePath
isoDir)
installDestSanityCheck InstallDirResolved
_ = () -> Excepts '[DirNotEmpty] m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Returns 'Nothing' for legacy installs.
getInstalledFiles :: ( MonadIO m
                     , MonadCatch m
                     , MonadReader env m
                     , HasDirs env
                     , MonadFail m
                     )
                  => Tool
                  -> GHCTargetVersion
                  -> m (Maybe [FilePath])
getInstalledFiles :: Tool -> GHCTargetVersion -> m (Maybe [FilePath])
getInstalledFiles Tool
t GHCTargetVersion
v' = [IOErrorType]
-> Maybe [FilePath] -> m (Maybe [FilePath]) -> m (Maybe [FilePath])
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] Maybe [FilePath]
forall a. Maybe a
Nothing (m (Maybe [FilePath]) -> m (Maybe [FilePath]))
-> m (Maybe [FilePath]) -> m (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ do
  FilePath
f <- Tool -> GHCTargetVersion -> m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
t GHCTargetVersion
v'
  (FilePath -> FilePath
forall a. NFData a => a -> a
force -> !FilePath
c) <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (FilePath -> IO FilePath
readFile FilePath
f IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO FilePath
forall a. a -> IO a
evaluate)
  Maybe [FilePath] -> m (Maybe [FilePath])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just ([FilePath] -> Maybe [FilePath]) -> [FilePath] -> Maybe [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
c)


-- | Warn if the installed and set HLS is not compatible with the installed and
-- set GHC version.
warnAboutHlsCompatibility :: ( MonadReader env m
                             , HasDirs env
                             , HasLog env
                             , MonadThrow m
                             , MonadCatch m
                             , MonadIO m
                             )
                          => m ()
warnAboutHlsCompatibility :: m ()
warnAboutHlsCompatibility = do
  [Version]
supportedGHC <- m [Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m [Version]
hlsGHCVersions
  Maybe Version
currentGHC   <- (GHCTargetVersion -> Version)
-> Maybe GHCTargetVersion -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHCTargetVersion -> Version
_tvVersion (Maybe GHCTargetVersion -> Maybe Version)
-> m (Maybe GHCTargetVersion) -> m (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> m (Maybe GHCTargetVersion)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
forall a. Maybe a
Nothing
  Maybe Version
currentHLS   <- m (Maybe Version)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m (Maybe Version)
hlsSet

  case (Maybe Version
currentGHC, Maybe Version
currentHLS) of
    (Just Version
gv, Just Version
hv) | Version
gv Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
supportedGHC -> do
      Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"GHC " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
gv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not compatible with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"Haskell Language Server " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
hv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"Haskell IDE support may not work until this is fixed." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"Install a different HLS version, or install and set one of the following GHCs:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        FilePath -> Text
T.pack ([Version] -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [Version]
supportedGHC)

    (Maybe Version, Maybe Version)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()



    -----------
    --[ Git ]--
    -----------



isCommitHash :: String -> Bool
isCommitHash :: FilePath -> Bool
isCommitHash FilePath
str' = let hex :: Bool
hex = (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit FilePath
str'
                        len :: Int
len = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
str'
                    in Bool
hex Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40


gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut :: [FilePath] -> FilePath -> Excepts '[ProcessError] m Text
gitOut [FilePath]
args FilePath
dir = do
  CapturedProcess {ByteString
ExitCode
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
$sel:_stdOut:CapturedProcess :: CapturedProcess -> ByteString
$sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
_stdErr :: ByteString
_stdOut :: ByteString
_exitCode :: ExitCode
..} <- m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess)
-> m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
forall (m :: * -> *).
MonadIO m =>
FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
executeOut FilePath
"git" [FilePath]
args (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)
  case ExitCode
_exitCode of
    ExitCode
ExitSuccess   -> Text -> Excepts '[ProcessError] m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Excepts '[ProcessError] m Text)
-> Text -> Excepts '[ProcessError] m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
stripNewlineEnd (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
_stdOut
    ExitFailure Int
c -> do
      let pe :: ProcessError
pe = Int -> FilePath -> [FilePath] -> ProcessError
NonZeroExit Int
c FilePath
"git" [FilePath]
args
      m () -> Excepts '[ProcessError] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[ProcessError] m ())
-> m () -> Excepts '[ProcessError] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (ProcessError -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ProcessError
pe)
      ProcessError -> Excepts '[ProcessError] m Text
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE ProcessError
pe

processBranches :: T.Text -> [String]
processBranches :: Text -> [FilePath]
processBranches Text
str' = let lines' :: [FilePath]
lines'   = FilePath -> [FilePath]
lines (Text -> FilePath
T.unpack Text
str')
                           words' :: [[FilePath]]
words'   = (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words [FilePath]
lines'
                           refs :: [FilePath]
refs     = [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath]) -> [Maybe FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ([FilePath] -> Maybe FilePath) -> [[FilePath]] -> [Maybe FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath] -> Int -> Maybe FilePath
forall a. [a] -> Int -> Maybe a
`atMay` Int
1) [[FilePath]]
words'
                           branches :: [FilePath]
branches = [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath]) -> [Maybe FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe FilePath) -> [FilePath] -> [Maybe FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"refs/heads/") ([FilePath] -> [Maybe FilePath]) -> [FilePath] -> [Maybe FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"refs/heads/") [FilePath]
refs
                       in [FilePath]
branches