{-# 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.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)
import System.Environment (getEnvironment, setEnv)
import Data.Time (Day(..), diffDays, addDays)


-- $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 :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binarySymLinkDestination [Char]
binDir [Char]
toolPath = do
  [Char]
toolPath' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
toolPath
  [Char]
binDir' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
binDir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char] -> [Char]
relativeSymlink [Char]
binDir' [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
 MonadThrow m, MonadFail m, MonadMask m) =>
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 {[Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
..}  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

  [[Char]]
files                         <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
    let f_xyz :: [Char]
f_xyz = [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
_tvVersion) forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
    let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f_xyz
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
 MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC Maybe Text
target = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  Maybe GHCTargetVersion
mtv                           <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
target
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GHCTargetVersion
mtv forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion
tv -> do
    [[Char]]
files <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
      let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
fullF
    -- old ghcup
    let hdc_file :: [Char]
hdc_file = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haddock-ghc" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
hdc_file)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
 MonadThrow m, MonadFail m, MonadMask m) =>
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 {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  (Int
mj, Int
mi) <- forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
_tvVersion
  let v' :: Text
v' = forall a. Integral a => a -> Text
intToText Int
mj forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Text
intToText Int
mi

  [[Char]]
files                         <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
    let f_xy :: [Char]
f_xy = [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
v' forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
    let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f_xy
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
 MonadThrow m, MonadFail m, MonadMask m) =>
Version -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks Version
ver = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

  [[Char]]
hlsBins <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> m [[Char]]
hlsAllBinaries Version
ver
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
hlsBins forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
    let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
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
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => [Char] -> m ()
rmFile [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
 MonadFail m, MonadIO m, MonadMask m) =>
Excepts '[NotInstalled] m ()
rmPlainHLS = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

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

  -- 'haskell-language-server-wrapper'
  let hlswrapper :: [Char]
hlswrapper = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
hlswrapper)
  if Bool
isWindows
  then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
hlswrapper
  else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => [Char] -> m ()
rmFile [Char]
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver = do
  GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesDirectoryExist (GHCupPath -> [Char]
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcSrcInstalled GHCTargetVersion
ver = do
  GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist (GHCupPath -> [Char]
fromGHCupPath GHCupPath
ghcdir [Char] -> [Char] -> [Char]
</> [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
mtarget = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let ghc :: [Char]
ghc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"ghc" (\Text
t -> Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"-ghc") Maybe Text
mtarget
  let ghcBin :: [Char]
ghcBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
ghc forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

  -- link destination is of the form ../ghc/<ver>/bin/ghc
  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
    [Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
ghcBin
    forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
ghcLinkVersion [Char]
link
 where
  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
  ghcLinkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
ghcLinkVersion ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt -> Text
t) = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity GHCTargetVersion
parser [Char]
"ghcLinkVersion" Text
t
   where
    parser :: ParsecT Void Text Identity GHCTargetVersion
parser =
        (do
           Text
_    <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 ParsecT Void Text Identity [Char]
ghcSubPath
           [Char]
_    <- ParsecT Void Text Identity [Char]
ghcSubPath
           Text
r    <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep
           Text
rest <- forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
           forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
r
           GHCTargetVersion
x <- ParsecT Void Text Identity GHCTargetVersion
ghcTargetVerP
           forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
           forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
x
         )
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
MP.takeRest
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof
    ghcSubPath :: ParsecT Void Text Identity [Char]
ghcSubPath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"ghc" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
m [Either [Char] GHCTargetVersion]
getInstalledGHCs = do
  GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupGHCBaseDir
  [[Char]]
fs     <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectoryDirs (GHCupPath -> [Char]
fromGHCupPath GHCupPath
ghcdir)
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fs forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
parseGHCupGHCDir [Char]
f of
    Right GHCTargetVersion
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right GHCTargetVersion
r
    Left  SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledCabals = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [[Char]]
bins   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^cabal-.*$|] :: ByteString))
  [Either [Char] Version]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"cabal-" [Char]
f) of
    Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
    Just (Left  ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
    Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Either [Char] Version]
vs


-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
cabalInstalled Version
ver = do
  [Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledCabals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall env (m :: * -> *).
(HasLog env, MonadReader env m, HasDirs env, MonadIO m,
 MonadThrow m, MonadCatch m) =>
m (Maybe Version)
cabalSet = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let cabalbin :: [Char]
cabalbin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"cabal" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

  forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
isBrokenSymlink [Char]
cabalbin
    if Bool
broken
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      else do
        Either SomeException [Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InvalidArgument
            (\IOException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall e. Exception e => e -> SomeException
toException IOException
e))
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
cabalbin
        case forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either SomeException [Char]
link of
          Right Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Version
v
          Left SomeException
err -> do
            forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse cabal symlink target with: "
              forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall e. Exception e => e -> [Char]
displayException SomeException
err)
              forall a. Semigroup a => a -> a -> a
<> Text
". The symlink "
              forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
cabalbin
              forall a. Semigroup a => a -> a -> a
<> Text
" needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
            forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity Version
parser [Char]
"linkVersion" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt

  parser :: ParsecT Void Text Identity Version
parser
    =   forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Version
cabalParse
  -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
  cabalParse :: ParsecT Void Text Identity Version
cabalParse = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"cabal-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
version'
  -- parses any path component ending with path separator,
  -- e.g. "foo/"
  stripPathComponet :: ParsecT Void Text Identity [Char]
stripPathComponet = forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 [[Char]]
stripAbsolutePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
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 [[Char]]
stripRelativePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledHLSs = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [[Char]]
bins                          <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (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 [Char] Version]
legacy <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f ->
    case
          Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"haskell-language-server-wrapper-" [Char]
f)
      of
        Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
        Just (Left  ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
        Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f

  GHCupPath
hlsdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupHLSBaseDir
  [[Char]]
fs     <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectoryDirs (GHCupPath -> [Char]
fromGHCupPath GHCupPath
hlsdir)
  [Either [Char] Version]
new <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fs forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseGHCupHLSDir [Char]
f of
    Right Version
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
    Left  SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Eq a => [a] -> [a]
nub ([Either [Char] Version]
new forall a. Semigroup a => a -> a -> a
<> [Either [Char] 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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledStacks = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [[Char]]
bins                          <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                   ExecOption
execBlank
                   ([s|^stack-.*$|] :: ByteString)
    )
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f ->
    case Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"stack-" [Char]
f) of
        Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
        Just (Left  ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
        Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m, HasLog env) =>
m (Maybe Version)
stackSet = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let stackBin :: [Char]
stackBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"stack" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

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

-- | Whether the given Stack version is installed.
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
stackInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
stackInstalled Version
ver = do
  [Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledStacks
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
hlsInstalled Version
ver = do
  [Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledHLSs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
isLegacyHLS Version
ver = do
  GHCupPath
bdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ GHCupPath -> [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m (Maybe Version)
hlsSet = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  let hlsBin :: [Char]
hlsBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- [Char] -> IO Bool
isBrokenSymlink [Char]
hlsBin
    if Bool
broken
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      else do
        [Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
hlsBin
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion [Char]
link
 where
  linkVersion :: MonadThrow m => FilePath -> m Version
  linkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity Version
parser [Char]
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt
   where
    parser :: ParsecT Void Text Identity Version
parser
      =   forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Version
cabalParse
    -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
    cabalParse :: ParsecT Void Text Identity Version
cabalParse = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-wrapper-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
version'
    -- parses any path component ending with path separator,
    -- e.g. "foo/"
    stripPathComponet :: ParsecT Void Text Identity [Char]
stripPathComponet = forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 [[Char]]
stripAbsolutePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
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 [[Char]]
stripRelativePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m [Version]
hlsGHCVersions = do
  Maybe Version
h <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m (Maybe Version)
hlsSet
  forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Version
h 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' :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
Version -> m [Version]
hlsGHCVersions' Version
v' = do
  [[Char]]
bins <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
v' forall a. Maybe a
Nothing
  let vers :: [Either (ParseErrorBundle Text Void) Version]
vers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (Text -> Either (ParseErrorBundle Text Void) Version
version
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"haskell-language-server-"
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"~"
          )
        [[Char]]
bins
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights 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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
ver Maybe Version
mghcVer = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
      CompOption
compExtended
      ExecOption
execBlank
      ([s|^haskell-language-server-|]
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [s|.*|] Version -> ByteString
escapeVerRex Maybe Version
mghcVer
        forall a. Semigroup a => a -> a -> a
<> [s|~|]
        forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver
        forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 ([Char] -> Text
T.pack [Char]
exeExt)
        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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> Maybe Version -> m [[Char]]
hlsInternalServerScripts Version
ver Maybe Version
mghcVer = do
  GHCupPath
dir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let bdir :: [Char]
bdir = GHCupPath -> [Char]
fromGHCupPath GHCupPath
dir [Char] -> [Char] -> [Char]
</> [Char]
"bin"
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadFail m) =>
Version -> Maybe Version -> m [[Char]]
hlsInternalServerBinaries Version
ver Maybe Version
mghcVer = do
  [Char]
dir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
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 [Char]
bdir) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), forall a b. b -> Either a b
Right Regex
regex, forall a b. a -> Either a b
Left [Char]
"bin"]
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadFail m) =>
Version -> Version -> m [[Char]]
hlsInternalServerLibs Version
ver Version
ghcVer = do
  [Char]
dir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
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 [Char]
bdir) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), forall a b. b -> Either a b
Right Regex
regex, forall a b. a -> Either a b
Left ([Char]
"lib" [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
ghcVer))]
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe [Char])
hlsWrapperBinary Version
ver = do
  Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
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 -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..}  <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [[Char]]
wrapper <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
      CompOption
compExtended
      ExecOption
execBlank
      ([s|^haskell-language-server-wrapper-|] forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 ([Char] -> Text
T.pack [Char]
exeExt) forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
      )
    )
  case [[Char]]
wrapper of
    []  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    [[Char]
x] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
x
    [[Char]]
_   -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> UnexpectedListLength
UnexpectedListLength
      [Char]
"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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> m [[Char]]
hlsAllBinaries Version
ver = do
  [[Char]]
hls     <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
ver forall a. Maybe a
Nothing
  Maybe [Char]
wrapper <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe [Char])
hlsWrapperBinary Version
ver
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a -> [a]
maybeToList Maybe [Char]
wrapper forall a. [a] -> [a] -> [a]
++ [[Char]]
hls)





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


-- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV :: forall (m :: * -> *). MonadThrow m => 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]
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
y)
  NonEmpty VChunk
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> ParseError
ParseError [Char]
"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 forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
v' of
  Just (Int
x, Int
y) -> Int
x forall a. Eq a => a -> a -> Bool
== Int
major' Bool -> Bool -> Bool
&& Int
y 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) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [Int]
prefix [Int]
full

toL :: PVP -> [Int]
toL :: PVP -> [Int]
toL (PVP NonEmpty Word
inner) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
PVP -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForPVP PVP
pvpIn Maybe Text
mt = do
  [GHCTargetVersion]
ghcs <- forall a b. [Either a b] -> [b]
rights forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
m [Either [Char] GHCTargetVersion]
getInstalledGHCs
  -- we're permissive here... failed parse just means we have no match anyway
  let ghcs' :: [(PVP, Text, Maybe Text)]
ghcs' = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GHCTargetVersion]
ghcs 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) <- forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP Version
_tvVersion
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP
pvp_, Text
rest, Maybe Text
_tvTarget)

  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' :: 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 = do
  let mResult :: Maybe (PVP, Text, Maybe Text)
mResult = forall a. [a] -> Maybe a
lastMay
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(PVP
x, Text
_, Maybe Text
_) (PVP
y, Text
_, Maybe Text
_) -> forall a. Ord a => a -> a -> Ordering
compare PVP
x PVP
y)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter
                      (\(PVP
pvp_, Text
_, Maybe Text
target) ->
                        Maybe Text
target forall a. Eq a => a -> a -> Bool
== Maybe Text
mt Bool -> Bool -> Bool
&& PVP -> PVP -> Bool
matchPVPrefix PVP
pvp_ PVP
pvpIn
                      )
                  forall a b. (a -> b) -> a -> b
$ [(PVP, Text, Maybe Text)]
ghcs'
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (PVP, Text, Maybe Text)
mResult forall a b. (a -> b) -> a -> b
$ \(PVP
pvp_, Text
rest, Maybe Text
target) -> do
    Version
ver' <- forall (m :: * -> *). MonadThrow m => PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest
    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
                 -> Maybe Text
                 -> PVP
                 -> GHCupDownloads
                 -> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor :: forall (m :: * -> *).
MonadThrow m =>
Tool
-> Maybe Text
-> PVP
-> GHCupDownloads
-> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor Tool
tool Maybe Text
target PVP
pvpIn GHCupDownloads
dls = do
  let ls :: [(GHCTargetVersion, VersionInfo)]
      ls :: [(GHCTargetVersion, VersionInfo)]
ls = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall s a. (s -> a) -> Getter s a
to forall k a. Map k a -> [(k, a)]
Map.toDescList) GHCupDownloads
dls
  let ps :: [((PVP, Text), VersionInfo, Maybe Text)]
      ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(GHCTargetVersion
v, VersionInfo
vi) -> (,VersionInfo
vi, GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
v)) [(GHCTargetVersion, VersionInfo)]
ls
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((PVP
pv', Text
_), VersionInfo
vi, Maybe Text
mt) -> (PVP
pv', VersionInfo
vi, Maybe Text
mt)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\((PVP
v, Text
_), VersionInfo
_, Maybe Text
t) -> PVP -> PVP -> Bool
matchPVPrefix PVP
pvpIn PVP
v Bool -> Bool -> Bool
&& Maybe Text
t forall a. Eq a => a -> a -> Bool
== Maybe Text
target) forall a b. (a -> b) -> a -> b
$ [((PVP, Text), VersionInfo, Maybe Text)]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
[Char] -> [Char] -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir [Char]
dfp [Char]
av = do
  let fn :: [Char]
fn = [Char] -> [Char]
takeFileName [Char]
av
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Unpacking: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fn forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
dfp

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

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

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


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

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

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

  -- extract, depending on file extension
  if
    | [Char]
".tar.gz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
      (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar.xz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> do
      ByteString
filecontents <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av
      let decompressed :: ByteString
decompressed = DecompressParams -> ByteString -> ByteString
Lzma.decompressWith (DecompressParams
Lzma.defaultDecompressParams { decompressAutoDecoder :: Bool
Lzma.decompressAutoDecoder= Bool
True }) ByteString
filecontents
      forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries ByteString
decompressed
    | [Char]
".tar.bz2" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn ->
      forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".zip" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | Bool
otherwise -> forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ [Char] -> UnknownArchive
UnknownArchive [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
bdir TarDir
tardir = case TarDir
tardir of
  RealDir [Char]
pr -> do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ GHCupPath -> [Char]
fromGHCupPath (GHCupPath
bdir GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
pr))
          (forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
bdir GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
pr)
  RegexDir [Char]
r -> do
    let rs :: [[Char]]
rs = forall a. (a -> Bool) -> [a] -> [[a]]
split (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
pathSeparators) [Char]
r
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\GHCupPath
y [Char]
x ->
        (forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex -> IO [[Char]]
findFiles (GHCupPath -> [Char]
fromGHCupPath GHCupPath
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex
regex forall a b. (a -> b) -> a -> b
$ [Char]
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
          []      -> forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir
          ([Char]
p : [[Char]]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
y GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
p)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
      )
      GHCupPath
bdir
      [[Char]]
rs
    where regex :: [Char] -> Regex
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 GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged :: Tag
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
tag =
  forall s a. (s -> a) -> Getter s a
to (forall k a. Map k a -> [(k, a)]
Map.toDescList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe Day
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:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
..} -> Tag
tag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tag]
_viTags))
  forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding forall a. a -> a
id

getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay :: GHCupDownloads
-> Tool
-> Day
-> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay GHCupDownloads
av Tool
tool Day
day = let mvv :: Map GHCTargetVersion VersionInfo
mvv = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool) GHCupDownloads
av
                                  mdv :: Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\GHCTargetVersion
k vi :: VersionInfo
vi@VersionInfo{[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
..} Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m ->
                                            forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m (\Day
d -> let diff :: Integer
diff = Day -> Day -> Integer
diffDays Day
d Day
day
                                                           in forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall a. Num a => a -> a
abs Integer
diff) (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)) Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m) Maybe Day
_viReleaseDay)
                                          forall k a. Map k a
Map.empty Map GHCTargetVersion VersionInfo
mvv
                              in case forall a. [a] -> Maybe a
headMay (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv) of
                                   Maybe (Integer, (Integer, (GHCTargetVersion, VersionInfo)))
Nothing -> forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
                                   Just (Integer
absDiff, (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)))
                                     | Integer
absDiff forall a. Eq a => a -> a -> Bool
== Integer
0 -> forall a b. b -> Either a b
Right (GHCTargetVersion
k, VersionInfo
vi)
                                     | Bool
otherwise -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (Integer -> Day -> Day
addDays Integer
diff Day
day))

getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold :: Day
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold Day
day = forall s a. (s -> a) -> Getter s a
to (forall k a. Map k a -> [(k, a)]
Map.toDescList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
..} -> forall a. a -> Maybe a
Just Day
day forall a. Eq a => a -> a -> Bool
== Maybe Day
_viReleaseDay)) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding forall a. a -> a
id

getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
Latest) GHCupDownloads
av

getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
LatestPrerelease) GHCupDownloads
av

getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
LatestNightly) GHCupDownloads
av

getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
Recommended) GHCupDownloads
av


-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion GHCupDownloads
av PVP
pvpVer =
  forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
GHC forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 GHCTargetVersion VersionInfo) (GHCTargetVersion, 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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> m [Char]
ghcInternalBinDir GHCTargetVersion
ver = do
  [Char]
ghcdir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
ghcdir [Char] -> [Char] -> [Char]
</> [Char]
"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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
ver = do
  [Char]
bindir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
 MonadIO m) =>
GHCTargetVersion -> m [Char]
ghcInternalBinDir GHCTargetVersion
ver

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

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

 where

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

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

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

  isNotAnyInfix :: [String] -> String -> Bool
  isNotAnyInfix :: [[Char]] -> [Char] -> Bool
isNotAnyInfix [[Char]]
xs [Char]
t = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
a Bool
b -> Bool -> Bool
not ([Char]
a forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
t) Bool -> Bool -> Bool
&& Bool
b) Bool
True [[Char]]
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 :: [Char]
ghcUpSrcBuiltFile = [Char]
".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 :: forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
 HasLog env, HasSettings env) =>
[[Char]] -> Maybe [Char] -> m (Either ProcessError ())
make [[Char]]
args Maybe [Char]
workdir = forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
 HasLog env, HasSettings env) =>
[[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
make' [[Char]]
args Maybe [Char]
workdir [Char]
"ghc-make" forall a. Maybe a
Nothing


-- | 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
      -> FilePath         -- ^ log filename (opened in append mode)
      -> Maybe [(String, String)] -- ^ optional environment
      -> m (Either ProcessError ())
make' :: forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
 HasLog env, HasSettings env) =>
[[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
make' [[Char]]
args Maybe [Char]
workdir [Char]
logfile Maybe [([Char], [Char])]
menv = do
  [[Char]]
spaths    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
  Bool
has_gmake <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([[Char]] -> [Char] -> IO (Maybe [Char])
searchPath [[Char]]
spaths [Char]
"gmake")
  let mymake :: [Char]
mymake = if Bool
has_gmake then [Char]
"gmake" else [Char]
"make"
  forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
 MonadIO m, MonadThrow m) =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
execLogged [Char]
mymake [[Char]]
args Maybe [Char]
workdir [Char]
logfile Maybe [([Char], [Char])]
menv


makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
        => [String]
        -> Maybe FilePath
        -> m CapturedProcess
makeOut :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
[[Char]] -> Maybe [Char] -> m CapturedProcess
makeOut [[Char]]
args Maybe [Char]
workdir = do
  [[Char]]
spaths    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
  Bool
has_gmake <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([[Char]] -> [Char] -> IO (Maybe [Char])
searchPath [[Char]]
spaths [Char]
"gmake")
  let mymake :: [Char]
mymake = if Bool
has_gmake then [Char]
"gmake" else [Char]
"make"
  forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
executeOut [Char]
mymake [[Char]]
args Maybe [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatches [Char]
pdir [Char]
ddir = do
  let lexicographical :: IO [[Char]]
lexicographical = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([Char]
pdir [Char] -> [Char] -> [Char]
</>) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Regex -> IO [[Char]]
findFiles
        [Char]
pdir
        (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 [[Char]]
quilt = forall a b. (a -> b) -> [a] -> [b]
map ([Char]
pdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile ([Char]
pdir [Char] -> [Char] -> [Char]
</> [Char]
"series")

  [[Char]]
patches <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO [[Char]]
quilt 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 [[Char]]
lexicographical 
    else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
patches forall a b. (a -> b) -> a -> b
$ \[Char]
patch' -> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch' [Char]
ddir


applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
           => FilePath   -- ^ Patch
           -> FilePath   -- ^ dir to apply patches in
           -> Excepts '[PatchFailed] m ()
applyPatch :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch [Char]
ddir = do
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Applying patch " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
patch
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just)
       (forall (m :: * -> *).
MonadIO m =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
exec
         [Char]
"patch"
         [[Char]
"-p1", [Char]
"-s", [Char]
"-f", [Char]
"-i", [Char]
patch]
         (forall a. a -> Maybe a
Just [Char]
ddir)
         forall a. Maybe a
Nothing)
    forall e (es :: IxList) 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, ContentLengthError, GPGError] m ()
applyAnyPatch :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
 MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
 MonadMask m, MonadIO m) =>
Maybe (Either [Char] [URI])
-> [Char]
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
applyAnyPatch Maybe (Either [Char] [URI])
Nothing [Char]
_                   = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
applyAnyPatch (Just (Left [Char]
pdir)) [Char]
workdir  = forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatches [Char]
pdir [Char]
workdir
applyAnyPatch (Just (Right [URI]
uris)) [Char]
workdir = do
  [Char]
tmpUnpack <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [URI]
uris forall a b. (a -> b) -> a -> b
$ \URI
uri -> do
    [Char]
patch <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
 MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> [Char]
-> Maybe [Char]
-> Bool
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Char]
tmpUnpack forall a. Maybe a
Nothing Bool
False
    forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch [Char]
workdir


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




getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog GHCupDownloads
dls Tool
tool (GHCVersion GHCTargetVersion
v') =
  forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v' forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolVersion (Version -> GHCTargetVersion
mkTVer -> GHCTargetVersion
v')) =
  forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v' forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolTag Tag
tag) =
  forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre (Tag
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
tag) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall s a. (s -> a) -> Getter s a
to forall a b. (a, b) -> b
snd forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolDay Day
day) =
  forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre (Day
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold Day
day) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall s a. (s -> a) -> Getter s a
to forall a b. (a, b) -> b
snd forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% 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 :: forall env (m :: * -> *) (e :: IxList) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
 MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
 MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$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:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never)
          forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  a
v <-
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction)
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never Bool -> Bool -> Bool
|| KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Errors) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  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 :: forall (e :: IxList) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
 MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
 MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$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:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) 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 :: forall env (m :: * -> *) (e :: IxList) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
 MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
 MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanFinally GHCupPath
bdir Excepts e m a
action = do
  Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$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:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) 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 :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
dir = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$
           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
               Text
"Couldn't remove build dir " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath GHCupPath
dir) forall a. Semigroup a => a -> a -> a
<> Text
", error was: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall e. Exception e => e -> [Char]
displayException IOException
e))
           forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
           forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmPathForcibly GHCupPath
dir)


getVersionInfo :: GHCTargetVersion
               -> Tool
               -> GHCupDownloads
               -> Maybe VersionInfo
getVersionInfo :: GHCTargetVersion -> Tool -> GHCupDownloads -> Maybe VersionInfo
getVersionInfo GHCTargetVersion
v' Tool
tool =
  forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf
    ( forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool
    forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall s a. (s -> a) -> Getter s a
to (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\GHCTargetVersion
k VersionInfo
_ -> GHCTargetVersion
k forall a. Eq a => a -> a -> Bool
== GHCTargetVersion
v'))
    forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% forall s a. (s -> a) -> Getter s a
to forall k a. Map k a -> [a]
Map.elems
    forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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
% 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, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools :: forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
 MonadReader env m, HasDirs env, HasSettings env, HasGHCupInfo env,
 MonadUnliftIO m, MonadFail m) =>
Excepts
  '[GPGError, DigestError, ContentLengthError, DownloadFailed,
    NoDownload]
  m
  ()
ensureGlobalTools
  | Bool
isWindows = do
      (GHCupInfo ToolRequirements
_ GHCupDownloads
_ Map GlobalTool DownloadInfo
gTools) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
      Dirs
dirs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
      DownloadInfo
shimDownload <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE @_ @'[NoDownload]
        forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left NoDownload
NoDownload) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalTool
ShimGen Map GlobalTool DownloadInfo
gTools
      let dl :: Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
dl = forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
 MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe [Char]
-> Maybe [Char]
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
downloadCached' DownloadInfo
shimDownload (forall a. a -> Maybe a
Just [Char]
"gs.exe") forall a. Maybe a
Nothing
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (\DigestError{} -> do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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..."
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) [Char] -> [Char] -> [Char]
</> [Char]
"gs.exe"))
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
[Char] -> m ()
recycleFile (GHCupPath -> [Char]
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) [Char] -> [Char] -> [Char]
</> [Char]
"gs.exe")
          forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] forall a b. (a -> b) -> a -> b
$ Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
dl
        ) forall e (es' :: IxList) (es'' :: IxList) (es :: IxList) 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` forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
dl
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs GHCupPath
baseDir [Char]
binDir GHCupPath
cacheDir GHCupPath
logsDir GHCupPath
confDir GHCupPath
trashDir GHCupPath
dbDir GHCupPath
tmpDir) = do
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir [Char] -> [Char] -> [Char]
</> [Char]
"ghc")
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir [Char] -> [Char] -> [Char]
</> [Char]
"hls")
  [Char] -> IO ()
createDirRecursive' [Char]
binDir
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
cacheDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
logsDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
confDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
trashDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
dbDir)
  [Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
tmpDir)
  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 -> [Char]
ghcBinaryName (GHCTargetVersion (Just Text
t) Version
_) = Text -> [Char]
T.unpack (Text
t forall a. Semigroup a => a -> a -> a
<> Text
"-ghc" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
exeExt)
ghcBinaryName (GHCTargetVersion Maybe Text
Nothing  Version
_) = Text -> [Char]
T.unpack (Text
"ghc" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
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 :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadMask m) =>
InstallDirResolved -> Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved [Char]
isoDir) = do
  forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] () forall a b. (a -> b) -> a -> b
$ do
    Bool
empty' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => SerialT m a -> m Bool
S.null forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
[Char] -> SerialT m [Char]
getDirectoryContentsRecursiveUnsafe [Char]
isoDir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
empty') (forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ [Char] -> DirNotEmpty
DirNotEmpty [Char]
isoDir)
installDestSanityCheck InstallDirResolved
_ = 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadCatch m, MonadReader env m, HasDirs env,
 MonadFail m) =>
Tool -> GHCTargetVersion -> m (Maybe [[Char]])
getInstalledFiles Tool
t GHCTargetVersion
v' = forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
  [Char]
f <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m [Char]
recordedInstallationFile Tool
t GHCTargetVersion
v'
  (forall a. NFData a => a -> a
force -> ![Char]
c) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    ([Char] -> IO [Char]
readFile [Char]
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
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 :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
 MonadCatch m, MonadIO m) =>
m ()
warnAboutHlsCompatibility = do
  [Version]
supportedGHC <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m [Version]
hlsGHCVersions
  Maybe Version
currentGHC   <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHCTargetVersion -> Version
_tvVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet forall a. Maybe a
Nothing
  Maybe Version
currentHLS   <- 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
supportedGHC -> do
      forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
        Text
"GHC-" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
gv) forall a. Semigroup a => a -> a -> a
<> Text
" appears to have no corresponding HLS-" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
hv) forall a. Semigroup a => a -> a -> a
<> Text
" binary." forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"Haskell IDE support may not work." forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"You can try to either: " forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"  1. Install a different HLS version (e.g. downgrade for older GHCs)" forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"  2. Install and set one of the following GHCs: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow [Version]
supportedGHC) forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"  3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
hv) forall a. Semigroup a => a -> a -> a
<> Text
" --ghc " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
gv) forall a. Semigroup a => a -> a -> a
<> Text
" --cabal-update\n" forall a. Semigroup a => a -> a -> a
<>
        Text
"     (see https://www.haskell.org/ghcup/guide/#hls for more information)"

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



addToPath :: FilePath
          -> Bool         -- ^ if False will prepend
          -> IO [(String, String)]
addToPath :: [Char] -> Bool -> IO [([Char], [Char])]
addToPath [Char]
path Bool
append = do
 Map [Char] [Char]
cEnv <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [([Char], [Char])]
getEnvironment
 let paths :: [[Char]]
paths          = [[Char]
"PATH", [Char]
"Path"]
     curPaths :: [[Char]]
curPaths       = (\[Char]
x -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Char] -> [[Char]]
splitSearchPath (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
x Map [Char] [Char]
cEnv)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[Char]]
paths
     {- HLINT ignore "Redundant bracket" -}
     newPath :: [Char]
newPath        = forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] (if Bool
append then ([[Char]]
curPaths forall a. [a] -> [a] -> [a]
++ [[Char]
path]) else ([Char]
path forall a. a -> [a] -> [a]
: [[Char]]
curPaths))
     envWithoutPath :: Map [Char] [Char]
envWithoutPath = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
x Map [Char] [Char]
y -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete [Char]
x Map [Char] [Char]
y) Map [Char] [Char]
cEnv [[Char]]
paths
     pathVar :: [Char]
pathVar        = if Bool
isWindows then [Char]
"Path" else [Char]
"PATH"
     envWithNewPath :: [([Char], [Char])]
envWithNewPath = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
pathVar [Char]
newPath Map [Char] [Char]
envWithoutPath
 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
setEnv [Char]
pathVar [Char]
newPath
 forall (m :: * -> *) a. Monad m => a -> m a
return [([Char], [Char])]
envWithNewPath


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



isCommitHash :: String -> Bool
isCommitHash :: [Char] -> Bool
isCommitHash [Char]
str' = let hex :: Bool
hex = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit [Char]
str'
                        len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str'
                    in Bool
hex Bool -> Bool -> Bool
&& Int
len 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 :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[[Char]] -> [Char] -> Excepts '[ProcessError] m Text
gitOut [[Char]]
args [Char]
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
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
executeOut [Char]
"git" [[Char]]
args (forall a. a -> Maybe a
Just [Char]
dir)
  case ExitCode
_exitCode of
    ExitCode
ExitSuccess   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stripNewlineEnd forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
_stdOut
    ExitFailure Int
c -> do
      let pe :: ProcessError
pe = Int -> [Char] -> [[Char]] -> ProcessError
NonZeroExit Int
c [Char]
"git" [[Char]]
args
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (forall e. (Pretty e, HFErrorProject e) => e -> [Char]
prettyHFError ProcessError
pe)
      forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE ProcessError
pe

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