{-# 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 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 = defaultSettings { cache = True, metaCache = 0, noNetwork = True }
-- >>> 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, ContentLengthError] $ 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' <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
toolPath
  [Char]
binDir' <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
binDir
  [Char] -> m [Char]
forall a. a -> m a
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
_tvTarget :: Maybe Text
_tvVersion :: Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
..} = do
  Dirs {[Char]
GHCupPath
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
..}  <- m Dirs -> Excepts '[NotInstalled] m Dirs
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[NotInstalled] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs

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

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

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

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


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


-- Return the currently set cabal version, if any.
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: forall env (m :: * -> *).
(HasLog env, MonadReader env m, HasDirs env, MonadIO m,
 MonadThrow m, MonadCatch m) =>
m (Maybe Version)
cabalSet = do
  Dirs {[Char]
GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
..}  <- m Dirs
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" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

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

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

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

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

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

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


-- Return the currently set hls version, if any.
hlsSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet :: forall env (m :: * -> *).
(HasLog env, MonadReader env m, HasDirs env, MonadIO m,
 MonadThrow m, MonadCatch m) =>
m (Maybe Version)
hlsSet = do
  Dirs {[Char]
GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
..}  <- m Dirs
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" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt

  IOErrorType
-> (IOException -> m (Maybe Version))
-> m (Maybe Version)
-> m (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> m (Maybe Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (m (Maybe Version) -> m (Maybe Version))
-> m (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
isBrokenSymlink [Char]
hlsBin
    if Bool
broken
      then do
        Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Broken symlink at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
hlsBin
        Maybe Version -> m (Maybe Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
      else do
        [Char]
link <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
hlsBin
        Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> m Version -> m (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m Version
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 = Either (ParseErrorBundle Text Void) Version -> m Version
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) Version -> m Version)
-> ([Char] -> Either (ParseErrorBundle Text Void) Version)
-> [Char]
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Version
-> [Char] -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser [Char]
"" (Text -> Either (ParseErrorBundle Text Void) Version)
-> ([Char] -> Text)
-> [Char]
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt
   where
    parser :: Parsec Void Text Version
parser
      =   Parsec Void Text Version -> Parsec Void Text Version
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath ParsecT Void Text Identity [[Char]]
-> Parsec Void Text Version -> Parsec Void Text Version
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version -> Parsec Void Text Version
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath ParsecT Void Text Identity [[Char]]
-> Parsec Void Text Version -> Parsec Void Text Version
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
cabalParse)
      Parsec Void Text Version
-> Parsec Void Text Version -> Parsec Void Text Version
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Version
cabalParse
    -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
    cabalParse :: Parsec Void Text Version
cabalParse = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-wrapper-" ParsecT Void Text Identity (Tokens Text)
-> Parsec Void Text Version -> Parsec Void Text Version
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
version'
    -- parses any path component ending with path separator,
    -- e.g. "foo/"
    stripPathComponet :: Parsec Void Text [Char]
stripPathComponet = Parsec Void Text Char -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep Parsec Void Text Text
-> Parsec Void Text [Char] -> Parsec Void Text [Char]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Char -> Parsec Void Text [Char]
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 = Parsec Void Text Char -> Parsec Void Text [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep Parsec Void Text [Char]
-> ParsecT Void Text Identity [[Char]]
-> ParsecT Void Text Identity [[Char]]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text [Char] -> ParsecT Void Text Identity [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text [Char] -> Parsec Void Text [Char]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text [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 = Parsec Void Text [Char] -> ParsecT Void Text Identity [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (Parsec Void Text [Char] -> Parsec Void Text [Char]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try Parsec Void Text [Char]
stripPathComponet)


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


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


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

-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
-- Returns the full path.
hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
                          => Version
                          -> Maybe Version   -- ^ optional GHC version
                          -> m [FilePath]
hlsInternalServerScripts :: 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 <- Version -> m GHCupPath
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"
  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
    ([[Char]] -> [[Char]]) -> m [[Char]] -> m [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
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 (GHCupPath -> [Char]) -> m GHCupPath -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
regex = CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
  (Just [Char]
bdir) <- ([[Char]] -> Maybe [Char]) -> m [[Char]] -> m (Maybe [Char])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
headMay (m [[Char]] -> m (Maybe [Char])) -> m [[Char]] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> m [[Char]]) -> IO [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [[Char] -> Either [Char] Regex
forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), Regex -> Either [Char] Regex
forall a b. b -> Either a b
Right Regex
regex, [Char] -> Either [Char] Regex
forall a b. a -> Either a b
Left [Char]
"bin"]
  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
    ([[Char]] -> [[Char]]) -> m [[Char]] -> m [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
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 (GHCupPath -> [Char]) -> m GHCupPath -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
  let regex :: Regex
regex = CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
  (Just [Char]
bdir) <- ([[Char]] -> Maybe [Char]) -> m [[Char]] -> m (Maybe [Char])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
headMay (m [[Char]] -> m (Maybe [Char])) -> m [[Char]] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> m [[Char]]) -> IO [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [[Char] -> Either [Char] Regex
forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), Regex -> Either [Char] Regex
forall a b. b -> Either a b
Right Regex
regex, [Char] -> Either [Char] Regex
forall a b. a -> Either a b
Left ([Char]
"lib" [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
ghcVer))]
  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]]) -> m [[Char]] -> m [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
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
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [[Char]]
wrapper <- IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> m [[Char]]) -> IO [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
    [Char]
binDir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
      CompOption
compExtended
      ExecOption
execBlank
      ([s|^haskell-language-server-wrapper-|] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 ([Char] -> Text
T.pack [Char]
exeExt) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
      )
    )
  case [[Char]]
wrapper of
    []  -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
    [[Char]
x] -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Char] -> m (Maybe [Char]))
-> Maybe [Char] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x
    [[Char]]
_   -> UnexpectedListLength -> m (Maybe [Char])
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedListLength -> m (Maybe [Char]))
-> UnexpectedListLength -> m (Maybe [Char])
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     <- Version -> Maybe Version -> m [[Char]]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
ver Maybe Version
forall a. Maybe a
Nothing
  Maybe [Char]
wrapper <- Version -> m (Maybe [Char])
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe [Char])
hlsWrapperBinary Version
ver
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList Maybe [Char]
wrapper [[Char]] -> [[Char]] -> [[Char]]
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 Maybe Word
_ (Chunks (Numeric Word
x :| Numeric Word
y : [Chunk]
_)) Maybe Release
_ Maybe Text
_) = (Int, Int) -> m (Int, Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
y)
getMajorMinorV Version
_ = ParseError -> m (Int, Int)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m (Int, Int)) -> ParseError -> m (Int, Int)
forall a b. (a -> b) -> a -> b
$ [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 Version -> Maybe (Int, Int)
forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
v' of
  Just (Int
x, Int
y) -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
major' Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
minor'
  Maybe (Int, Int)
Nothing     -> Bool
False

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

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


-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
-- PVP version.
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
             => PVP
             -> Maybe Text -- ^ the target triple
             -> m (Maybe GHCTargetVersion)
getGHCForPVP :: 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 <- [Either [Char] GHCTargetVersion] -> [GHCTargetVersion]
forall a b. [Either a b] -> [b]
rights ([Either [Char] GHCTargetVersion] -> [GHCTargetVersion])
-> m [Either [Char] GHCTargetVersion] -> m [GHCTargetVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Either [Char] GHCTargetVersion]
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' = [Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [Maybe (PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ ((GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
 -> [GHCTargetVersion] -> [Maybe (PVP, Text, Maybe Text)])
-> [GHCTargetVersion]
-> (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [Maybe (PVP, Text, Maybe Text)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [GHCTargetVersion] -> [Maybe (PVP, Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GHCTargetVersion]
ghcs ((GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
 -> [Maybe (PVP, Text, Maybe Text)])
-> (GHCTargetVersion -> Maybe (PVP, Text, Maybe Text))
-> [Maybe (PVP, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion{Maybe Text
Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
_tvTarget :: Maybe Text
_tvVersion :: Version
..} -> do
        (PVP
pvp_, Text
rest) <- Version -> Maybe (PVP, Text)
forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP Version
_tvVersion
        (PVP, Text, Maybe Text) -> Maybe (PVP, Text, Maybe Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP
pvp_, Text
rest, Maybe Text
_tvTarget)

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

-- | Like 'getGHCForPVP', except with explicit input parameter.
--
-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 8 :| [Numeric 10,Numeric 7]), _vRel = Just (Release (Alphanum "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 = [(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text)
forall a. [a] -> Maybe a
lastMay
                  ([(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text))
-> ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [(PVP, Text, Maybe Text)]
-> Maybe (PVP, Text, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PVP, Text, Maybe Text) -> (PVP, Text, Maybe Text) -> Ordering)
-> [(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(PVP
x, Text
_, Maybe Text
_) (PVP
y, Text
_, Maybe Text
_) -> PVP -> PVP -> Ordering
forall a. Ord a => a -> a -> Ordering
compare PVP
x PVP
y)
                  ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> ([(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)])
-> [(PVP, Text, Maybe Text)]
-> [(PVP, Text, Maybe Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PVP, Text, Maybe Text) -> Bool)
-> [(PVP, Text, Maybe Text)] -> [(PVP, Text, Maybe Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter
                      (\(PVP
pvp_, Text
_, Maybe Text
target) ->
                        Maybe Text
target Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
mt Bool -> Bool -> Bool
&& PVP -> PVP -> Bool
matchPVPrefix PVP
pvp_ PVP
pvpIn
                      )
                  ([(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text))
-> [(PVP, Text, Maybe Text)] -> Maybe (PVP, Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [(PVP, Text, Maybe Text)]
ghcs'
  Maybe (PVP, Text, Maybe Text)
-> ((PVP, Text, Maybe Text) -> m GHCTargetVersion)
-> m (Maybe GHCTargetVersion)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (PVP, Text, Maybe Text)
mResult (((PVP, Text, Maybe Text) -> m GHCTargetVersion)
 -> m (Maybe GHCTargetVersion))
-> ((PVP, Text, Maybe Text) -> m GHCTargetVersion)
-> m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ \(PVP
pvp_, Text
rest, Maybe Text
target) -> do
    Version
ver' <- PVP -> Text -> m Version
forall (m :: * -> *). MonadThrow m => PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest
    GHCTargetVersion -> m GHCTargetVersion
forall a. a -> m a
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) (\(p, _, _) -> p) $ getLatestToolFor GHC Nothing [pver|8|] r
-- Just (PVP {_pComponents = 8 :| [10,7]})
-- >>> (fmap . fmap) (\(p, _, _) -> p) $ getLatestToolFor GHC Nothing [pver|8.8|] r
-- Just (PVP {_pComponents = 8 :| [8,4]})
-- >>> (fmap . fmap) (\(p, _, _) -> p) $ getLatestToolFor GHC Nothing [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 = [(GHCTargetVersion, VersionInfo)]
-> Maybe [(GHCTargetVersion, VersionInfo)]
-> [(GHCTargetVersion, VersionInfo)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(GHCTargetVersion, VersionInfo)]
 -> [(GHCTargetVersion, VersionInfo)])
-> Maybe [(GHCTargetVersion, VersionInfo)]
-> [(GHCTargetVersion, VersionInfo)]
forall a b. (a -> b) -> a -> b
$ Optic'
  An_AffineFold '[] GHCupDownloads [(GHCTargetVersion, VersionInfo)]
-> GHCupDownloads -> Maybe [(GHCTargetVersion, VersionInfo)]
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
-> Optic'
     An_AffineFold '[] GHCupDownloads [(GHCTargetVersion, VersionInfo)]
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
% (Map GHCTargetVersion VersionInfo
 -> [(GHCTargetVersion, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to Map GHCTargetVersion VersionInfo
-> [(GHCTargetVersion, VersionInfo)]
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 = [Maybe ((PVP, Text), VersionInfo, Maybe Text)]
-> [((PVP, Text), VersionInfo, Maybe Text)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ((PVP, Text), VersionInfo, Maybe Text)]
 -> [((PVP, Text), VersionInfo, Maybe Text)])
-> [Maybe ((PVP, Text), VersionInfo, Maybe Text)]
-> [((PVP, Text), VersionInfo, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ ((GHCTargetVersion, VersionInfo)
 -> Maybe ((PVP, Text), VersionInfo, Maybe Text))
-> [(GHCTargetVersion, VersionInfo)]
-> [Maybe ((PVP, Text), VersionInfo, Maybe Text)]
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) ((PVP, Text) -> ((PVP, Text), VersionInfo, Maybe Text))
-> Maybe (PVP, Text)
-> Maybe ((PVP, Text), VersionInfo, Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> Maybe (PVP, Text)
forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
v)) [(GHCTargetVersion, VersionInfo)]
ls
  Maybe (PVP, VersionInfo, Maybe Text)
-> m (Maybe (PVP, VersionInfo, Maybe Text))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PVP, VersionInfo, Maybe Text)
 -> m (Maybe (PVP, VersionInfo, Maybe Text)))
-> ([((PVP, Text), VersionInfo, Maybe Text)]
    -> Maybe (PVP, VersionInfo, Maybe Text))
-> [((PVP, Text), VersionInfo, Maybe Text)]
-> m (Maybe (PVP, VersionInfo, Maybe Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((PVP, Text), VersionInfo, Maybe Text)
 -> (PVP, VersionInfo, Maybe Text))
-> Maybe ((PVP, Text), VersionInfo, Maybe Text)
-> Maybe (PVP, VersionInfo, Maybe Text)
forall a b. (a -> b) -> Maybe a -> Maybe b
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)) (Maybe ((PVP, Text), VersionInfo, Maybe Text)
 -> Maybe (PVP, VersionInfo, Maybe Text))
-> ([((PVP, Text), VersionInfo, Maybe Text)]
    -> Maybe ((PVP, Text), VersionInfo, Maybe Text))
-> [((PVP, Text), VersionInfo, Maybe Text)]
-> Maybe (PVP, VersionInfo, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((PVP, Text), VersionInfo, Maybe Text)]
-> Maybe ((PVP, Text), VersionInfo, Maybe Text)
forall a. [a] -> Maybe a
headMay ([((PVP, Text), VersionInfo, Maybe Text)]
 -> Maybe ((PVP, Text), VersionInfo, Maybe Text))
-> ([((PVP, Text), VersionInfo, Maybe Text)]
    -> [((PVP, Text), VersionInfo, Maybe Text)])
-> [((PVP, Text), VersionInfo, Maybe Text)]
-> Maybe ((PVP, Text), VersionInfo, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((PVP, Text), VersionInfo, Maybe Text) -> Bool)
-> [((PVP, Text), VersionInfo, Maybe Text)]
-> [((PVP, Text), VersionInfo, Maybe Text)]
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
target) ([((PVP, Text), VersionInfo, Maybe Text)]
 -> m (Maybe (PVP, VersionInfo, Maybe Text)))
-> [((PVP, Text), VersionInfo, Maybe Text)]
-> m (Maybe (PVP, VersionInfo, Maybe Text))
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
  m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[UnknownArchive, ArchiveResult] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Unpacking: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
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 = m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ()
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM (m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ())
-> (ByteString -> m (Either ArchiveResult ()))
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ArchiveResult ()) -> m (Either ArchiveResult ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ArchiveResult ()) -> m (Either ArchiveResult ()))
-> (ByteString -> IO (Either ArchiveResult ()))
-> ByteString
-> m (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM () -> IO (Either ArchiveResult ())
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM () -> IO (Either ArchiveResult ()))
-> (ByteString -> ArchiveM ())
-> ByteString
-> IO (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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 = IO ByteString -> Excepts '[ArchiveResult] m ByteString
forall a. IO a -> Excepts '[ArchiveResult] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Excepts '[ArchiveResult] m ByteString)
-> ([Char] -> IO ByteString)
-> [Char]
-> Excepts '[ArchiveResult] m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
BL.readFile

  -- extract, depending on file extension
  if
    | [Char]
".tar.gz" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
      (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar.xz" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> do
      ByteString
filecontents <- Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ByteString
 -> Excepts '[UnknownArchive, ArchiveResult] m ByteString)
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Excepts '[ArchiveResult] m ByteString
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
      Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ()
 -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar ByteString
decompressed
    | [Char]
".tar.bz2" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn ->
      Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".zip" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m ()
-> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar (ByteString -> Excepts '[ArchiveResult] m ())
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | Bool
otherwise -> UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> UnknownArchive -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ [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 = (([Entry [Char] ByteString] -> [[Char]])
-> Excepts '[ArchiveResult] m [Entry [Char] ByteString]
-> Excepts '[ArchiveResult] m [[Char]]
forall a b.
(a -> b)
-> Excepts '[ArchiveResult] m a -> Excepts '[ArchiveResult] m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Entry [Char] ByteString] -> [[Char]])
 -> Excepts '[ArchiveResult] m [Entry [Char] ByteString]
 -> Excepts '[ArchiveResult] m [[Char]])
-> ((Entry [Char] ByteString -> [Char])
    -> [Entry [Char] ByteString] -> [[Char]])
-> (Entry [Char] ByteString -> [Char])
-> Excepts '[ArchiveResult] m [Entry [Char] ByteString]
-> Excepts '[ArchiveResult] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry [Char] ByteString -> [Char])
-> [Entry [Char] ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Entry [Char] ByteString -> [Char]
forall fp e. Entry fp e -> fp
filepath (Excepts '[ArchiveResult] m [Entry [Char] ByteString]
 -> Excepts '[ArchiveResult] m [[Char]])
-> (ByteString
    -> Excepts '[ArchiveResult] m [Entry [Char] ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ArchiveResult [Entry [Char] ByteString]
-> Excepts '[ArchiveResult] m [Entry [Char] ByteString]
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE (Either ArchiveResult [Entry [Char] ByteString]
 -> Excepts '[ArchiveResult] m [Entry [Char] ByteString])
-> (ByteString -> Either ArchiveResult [Entry [Char] ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [Entry [Char] ByteString]
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 = IO ByteString -> Excepts '[ArchiveResult] m ByteString
forall a. IO a -> Excepts '[ArchiveResult] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Excepts '[ArchiveResult] m ByteString)
-> ([Char] -> IO ByteString)
-> [Char]
-> Excepts '[ArchiveResult] m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
BL.readFile

  -- extract, depending on file extension
  if
    | [Char]
".tar.gz" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
      (ByteString -> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar.xz" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> do
      ByteString
filecontents <- Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m ByteString
 -> Excepts '[UnknownArchive, ArchiveResult] m ByteString)
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Excepts '[ArchiveResult] m ByteString
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
      Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ArchiveResult] m [[Char]]
 -> Excepts '[UnknownArchive, ArchiveResult] m [[Char]])
-> Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString -> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries ByteString
decompressed
    | [Char]
".tar.bz2" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn ->
      Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> (ByteString -> ByteString)
-> ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".tar" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | [Char]
".zip" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> Excepts '[ArchiveResult] m [[Char]]
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (ByteString -> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries (ByteString -> Excepts '[ArchiveResult] m [[Char]])
-> Excepts '[ArchiveResult] m ByteString
-> Excepts '[ArchiveResult] m [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Excepts '[ArchiveResult] m ByteString
forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
    | Bool
otherwise -> UnknownArchive
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (UnknownArchive
 -> Excepts '[UnknownArchive, ArchiveResult] m [[Char]])
-> UnknownArchive
-> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
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
    Excepts '[TarDirDoesNotExist] m Bool
-> Excepts '[TarDirDoesNotExist] m ()
-> Excepts '[TarDirDoesNotExist] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool)
-> Excepts '[TarDirDoesNotExist] m Bool
-> Excepts '[TarDirDoesNotExist] m Bool
forall a b.
(a -> b)
-> Excepts '[TarDirDoesNotExist] m a
-> Excepts '[TarDirDoesNotExist] m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Excepts '[TarDirDoesNotExist] m Bool
 -> Excepts '[TarDirDoesNotExist] m Bool)
-> ([Char] -> Excepts '[TarDirDoesNotExist] m Bool)
-> [Char]
-> Excepts '[TarDirDoesNotExist] m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Excepts '[TarDirDoesNotExist] m Bool
forall a. IO a -> Excepts '[TarDirDoesNotExist] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[TarDirDoesNotExist] m Bool)
-> ([Char] -> IO Bool)
-> [Char]
-> Excepts '[TarDirDoesNotExist] m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Bool
doesDirectoryExist ([Char] -> Excepts '[TarDirDoesNotExist] m Bool)
-> [Char] -> Excepts '[TarDirDoesNotExist] m Bool
forall a b. (a -> b) -> a -> b
$ GHCupPath -> [Char]
fromGHCupPath (GHCupPath
bdir GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
pr))
          (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ()
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ())
-> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m ()
forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir)
    GHCupPath -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall a. a -> Excepts '[TarDirDoesNotExist] m a
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 = (Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
pathSeparators) [Char]
r
    (GHCupPath -> [Char] -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> GHCupPath
-> [[Char]]
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\GHCupPath
y [Char]
x ->
        ((IOException -> Excepts '[TarDirDoesNotExist] m [[Char]])
-> Excepts '[TarDirDoesNotExist] m [[Char]]
-> Excepts '[TarDirDoesNotExist] m [[Char]]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [[Char]] -> Excepts '[TarDirDoesNotExist] m [[Char]]
forall a. a -> Excepts '[TarDirDoesNotExist] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Excepts '[TarDirDoesNotExist] m [[Char]]
 -> Excepts '[TarDirDoesNotExist] m [[Char]])
-> ([Char] -> Excepts '[TarDirDoesNotExist] m [[Char]])
-> [Char]
-> Excepts '[TarDirDoesNotExist] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [[Char]] -> Excepts '[TarDirDoesNotExist] m [[Char]]
forall a. IO a -> Excepts '[TarDirDoesNotExist] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> Excepts '[TarDirDoesNotExist] m [[Char]])
-> ([Char] -> IO [[Char]])
-> [Char]
-> Excepts '[TarDirDoesNotExist] m [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex -> IO [[Char]]
findFiles (GHCupPath -> [Char]
fromGHCupPath GHCupPath
y) (Regex -> IO [[Char]])
-> ([Char] -> Regex) -> [Char] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex
regex ([Char] -> Excepts '[TarDirDoesNotExist] m [[Char]])
-> [Char] -> Excepts '[TarDirDoesNotExist] m [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
x) Excepts '[TarDirDoesNotExist] m [[Char]]
-> ([[Char]] -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall a b.
Excepts '[TarDirDoesNotExist] m a
-> (a -> Excepts '[TarDirDoesNotExist] m b)
-> Excepts '[TarDirDoesNotExist] m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
          []      -> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> TarDirDoesNotExist -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir
          ([Char]
p : [[Char]]
_) -> GHCupPath -> Excepts '[TarDirDoesNotExist] m GHCupPath
forall a. a -> Excepts '[TarDirDoesNotExist] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
y GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
p)) ([[Char]] -> Excepts '[TarDirDoesNotExist] m GHCupPath)
-> ([[Char]] -> [[Char]])
-> [[Char]]
-> Excepts '[TarDirDoesNotExist] m GHCupPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort
      )
      GHCupPath
bdir
      [[Char]]
rs
    where regex :: [Char] -> Regex
regex = CompOption -> ExecOption -> [Char] -> 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 =
  (Map GHCTargetVersion VersionInfo
 -> [(GHCTargetVersion, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to (Map GHCTargetVersion VersionInfo
-> [(GHCTargetVersion, VersionInfo)]
forall k a. Map k a -> [(k, a)]
Map.toDescList (Map GHCTargetVersion VersionInfo
 -> [(GHCTargetVersion, VersionInfo)])
-> (Map GHCTargetVersion VersionInfo
    -> Map GHCTargetVersion VersionInfo)
-> Map GHCTargetVersion VersionInfo
-> [(GHCTargetVersion, VersionInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionInfo -> Bool)
-> Map GHCTargetVersion VersionInfo
-> Map GHCTargetVersion VersionInfo
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
_viTags :: [Tag]
_viReleaseDay :: Maybe Day
_viChangeLog :: Maybe URI
_viSourceDL :: Maybe DownloadInfo
_viTestDL :: Maybe DownloadInfo
_viArch :: ArchitectureSpec
_viPostInstall :: Maybe Text
_viPostRemove :: Maybe Text
_viPreCompile :: Maybe Text
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
..} -> Tag
tag Tag -> [Tag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tag]
_viTags))
  Optic
  A_Getter
  '[]
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
  [(GHCTargetVersion, VersionInfo)]
  [(GHCTargetVersion, VersionInfo)]
-> Optic
     A_Fold
     '[]
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
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
% ([(GHCTargetVersion, VersionInfo)]
 -> [(GHCTargetVersion, VersionInfo)])
-> Optic
     A_Fold
     '[]
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding [(GHCTargetVersion, VersionInfo)]
-> [(GHCTargetVersion, VersionInfo)]
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 = Map GHCTargetVersion VersionInfo
-> Maybe (Map GHCTargetVersion VersionInfo)
-> Map GHCTargetVersion VersionInfo
forall a. a -> Maybe a -> a
fromMaybe Map GHCTargetVersion VersionInfo
forall a. Monoid a => a
mempty (Maybe (Map GHCTargetVersion VersionInfo)
 -> Map GHCTargetVersion VersionInfo)
-> Maybe (Map GHCTargetVersion VersionInfo)
-> Map GHCTargetVersion VersionInfo
forall a b. (a -> b) -> a -> b
$ Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> GHCupDownloads -> Maybe (Map GHCTargetVersion VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool) GHCupDownloads
av
                                  mdv :: Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv = (GHCTargetVersion
 -> VersionInfo
 -> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
 -> Map Integer (Integer, (GHCTargetVersion, VersionInfo)))
-> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
-> Map GHCTargetVersion VersionInfo
-> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
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
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
_viTags :: [Tag]
_viReleaseDay :: Maybe Day
_viChangeLog :: Maybe URI
_viSourceDL :: Maybe DownloadInfo
_viTestDL :: Maybe DownloadInfo
_viArch :: ArchitectureSpec
_viPostInstall :: Maybe Text
_viPostRemove :: Maybe Text
_viPreCompile :: Maybe Text
..} Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m ->
                                            Map Integer (Integer, (GHCTargetVersion, VersionInfo))
-> (Day -> Map Integer (Integer, (GHCTargetVersion, VersionInfo)))
-> Maybe Day
-> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
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 Integer
-> (Integer, (GHCTargetVersion, VersionInfo))
-> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
-> Map Integer (Integer, (GHCTargetVersion, VersionInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Integer -> Integer
forall a. Num a => a -> a
abs Integer
diff) (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)) Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m) Maybe Day
_viReleaseDay)
                                          Map Integer (Integer, (GHCTargetVersion, VersionInfo))
forall k a. Map k a
Map.empty Map GHCTargetVersion VersionInfo
mvv
                              in case [(Integer, (Integer, (GHCTargetVersion, VersionInfo)))]
-> Maybe (Integer, (Integer, (GHCTargetVersion, VersionInfo)))
forall a. [a] -> Maybe a
headMay (Map Integer (Integer, (GHCTargetVersion, VersionInfo))
-> [(Integer, (Integer, (GHCTargetVersion, VersionInfo)))]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv) of
                                   Maybe (Integer, (Integer, (GHCTargetVersion, VersionInfo)))
Nothing -> Maybe Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
forall a b. a -> Either a b
Left Maybe Day
forall a. Maybe a
Nothing
                                   Just (Integer
absDiff, (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)))
                                     | Integer
absDiff Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> (GHCTargetVersion, VersionInfo)
-> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
forall a b. b -> Either a b
Right (GHCTargetVersion
k, VersionInfo
vi)
                                     | Bool
otherwise -> Maybe Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
forall a b. a -> Either a b
Left (Day -> Maybe Day
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 = (Map GHCTargetVersion VersionInfo
 -> [(GHCTargetVersion, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to (Map GHCTargetVersion VersionInfo
-> [(GHCTargetVersion, VersionInfo)]
forall k a. Map k a -> [(k, a)]
Map.toDescList (Map GHCTargetVersion VersionInfo
 -> [(GHCTargetVersion, VersionInfo)])
-> (Map GHCTargetVersion VersionInfo
    -> Map GHCTargetVersion VersionInfo)
-> Map GHCTargetVersion VersionInfo
-> [(GHCTargetVersion, VersionInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionInfo -> Bool)
-> Map GHCTargetVersion VersionInfo
-> Map GHCTargetVersion VersionInfo
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:_viTags:VersionInfo :: VersionInfo -> [Tag]
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
_viTags :: [Tag]
_viReleaseDay :: Maybe Day
_viChangeLog :: Maybe URI
_viSourceDL :: Maybe DownloadInfo
_viTestDL :: Maybe DownloadInfo
_viArch :: ArchitectureSpec
_viPostInstall :: Maybe Text
_viPostRemove :: Maybe Text
_viPreCompile :: Maybe Text
..} -> Day -> Maybe Day
forall a. a -> Maybe a
Just Day
day Maybe Day -> Maybe Day -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Day
_viReleaseDay)) Optic
  A_Getter
  '[]
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
  [(GHCTargetVersion, VersionInfo)]
  [(GHCTargetVersion, VersionInfo)]
-> Optic
     A_Fold
     '[]
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
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
% ([(GHCTargetVersion, VersionInfo)]
 -> [(GHCTargetVersion, VersionInfo)])
-> Optic
     A_Fold
     '[]
     [(GHCTargetVersion, VersionInfo)]
     [(GHCTargetVersion, VersionInfo)]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding [(GHCTargetVersion, VersionInfo)]
-> [(GHCTargetVersion, VersionInfo)]
forall a. a -> a
id

getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest GHCupDownloads
av Tool
tool = Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
-> GHCupDownloads -> Maybe (GHCTargetVersion, VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
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 = Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
-> GHCupDownloads -> Maybe (GHCTargetVersion, VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
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 = Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
-> GHCupDownloads -> Maybe (GHCTargetVersion, VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
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 = Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
-> GHCupDownloads -> Maybe (GHCTargetVersion, VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
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 =
  Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
-> GHCupDownloads -> Maybe (GHCTargetVersion, VersionInfo)
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
GHC Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Fold
     (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic' A_Fold '[] GHCupDownloads (GHCTargetVersion, VersionInfo)
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 (GHCupPath -> [Char]) -> m GHCupPath -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GHCTargetVersion -> m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
  [Char] -> m [Char]
forall a. a -> m a
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 <- GHCTargetVersion -> Excepts '[NotInstalled] m [Char]
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
  Excepts '[NotInstalled] m Bool
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall a b.
(a -> b)
-> Excepts '[NotInstalled] m a -> Excepts '[NotInstalled] m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver)
        (NotInstalled -> Excepts '[NotInstalled] m ()
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))

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

 where

  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
  groupToolFiles :: [[Char]] -> [[([Char], [Char])]]
groupToolFiles = (([Char], [Char]) -> ([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [[([Char], [Char])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\([Char]
a, [Char]
_) ([Char]
b, [Char]
_) -> [Char]
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
b) ([([Char], [Char])] -> [[([Char], [Char])]])
-> ([[Char]] -> [([Char], [Char])])
-> [[Char]]
-> [[([Char], [Char])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ([Char], [Char])) -> [[Char]] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
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 = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([[Char]] -> [Char] -> Bool
isNotAnyInfix [[Char]]
blackListedTools) ([[Char]] -> [[Char]])
-> ([[([Char], [Char])]] -> [[Char]])
-> [[([Char], [Char])]]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]])
-> ([[([Char], [Char])]] -> [[Char]])
-> [[([Char], [Char])]]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], [Char])] -> [[Char]])
-> ([[([Char], [Char])]] -> [([Char], [Char])])
-> [[([Char], [Char])]]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"") ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ([([Char], [Char])] -> [([Char], [Char])])
-> ([[([Char], [Char])]] -> [([Char], [Char])])
-> [[([Char], [Char])]]
-> [([Char], [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[([Char], [Char])]] -> [([Char], [Char])]
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 = ([Char] -> Bool -> Bool) -> Bool -> [[Char]] -> Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
a Bool
b -> Bool -> Bool
not ([Char]
a [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
t) Bool -> Bool -> Bool
&& Bool
b) Bool
True [[Char]]
xs



-- | 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 = [[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
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" Maybe [([Char], [Char])]
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    <- IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
  Bool
has_gmake <- Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool) -> m (Maybe [Char]) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
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"
  [Char]
-> [[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
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    <- IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
  Bool
has_gmake <- Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool) -> m (Maybe [Char]) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
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"
  [Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
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 = (([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]])
-> (([Char] -> [Char]) -> [[Char]] -> [[Char]])
-> ([Char] -> [Char])
-> IO [[Char]]
-> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([Char]
pdir [Char] -> [Char] -> [Char]
</>) (IO [[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Regex -> IO [[Char]]
findFiles
        [Char]
pdir
        (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                       ExecOption
execBlank
                       ([s|.+\.(patch|diff)$|] :: ByteString)
        )
  let quilt :: IO [[Char]]
quilt = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
pdir [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
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 <- IO [[Char]] -> Excepts '[PatchFailed] m [[Char]]
forall a. IO a -> Excepts '[PatchFailed] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> Excepts '[PatchFailed] m [[Char]])
-> IO [[Char]] -> Excepts '[PatchFailed] m [[Char]]
forall a b. (a -> b) -> a -> b
$ IO [[Char]]
quilt IO [[Char]] -> (IOException -> IO [[Char]]) -> IO [[Char]]
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 IOException -> IO [[Char]]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
  [[Char]]
-> ([Char] -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
patches (([Char] -> Excepts '[PatchFailed] m ())
 -> Excepts '[PatchFailed] m ())
-> ([Char] -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ \[Char]
patch' -> [Char] -> [Char] -> Excepts '[PatchFailed] m ()
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
  m () -> Excepts '[PatchFailed] m ()
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[PatchFailed] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[PatchFailed] m ())
-> m () -> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Applying patch " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
patch
  (Either ProcessError () -> Maybe ())
-> m (Either ProcessError ()) -> m (Maybe ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProcessError -> Maybe ())
-> (() -> Maybe ()) -> Either ProcessError () -> Maybe ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe () -> ProcessError -> Maybe ()
forall a b. a -> b -> a
const Maybe ()
forall a. Maybe a
Nothing) () -> Maybe ()
forall a. a -> Maybe a
Just)
       ([Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
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]
         ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
ddir)
         Maybe [([Char], [Char])]
forall a. Maybe a
Nothing)
    m (Maybe ()) -> PatchFailed -> Excepts '[PatchFailed] m ()
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]
_                   = ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall a.
a
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
applyAnyPatch (Just (Left [Char]
pdir)) [Char]
workdir  = Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[PatchFailed] m ()
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
        GPGError]
      m
      ())
-> Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Excepts '[PatchFailed] m ()
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 (GHCupPath -> [Char])
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     GHCupPath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCupPath
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     GHCupPath
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
 MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
 MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
  [URI]
-> (URI
    -> Excepts
         '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
           GPGError]
         m
         ())
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [URI]
uris ((URI
  -> Excepts
       '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
         GPGError]
       m
       ())
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
        GPGError]
      m
      ())
-> (URI
    -> Excepts
         '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
           GPGError]
         m
         ())
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall a b. (a -> b) -> a -> b
$ \URI
uri -> do
    [Char]
patch <- Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     [Char]
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts
   '[DigestError, ContentLengthError, DownloadFailed, GPGError]
   m
   [Char]
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
        GPGError]
      m
      [Char])
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     [Char]
forall a b. (a -> b) -> a -> b
$ URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> [Char]
-> Maybe [Char]
-> Bool
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
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 Maybe URI
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing [Char]
tmpUnpack Maybe [Char]
forall a. Maybe a
Nothing Bool
False
    Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[PatchFailed] m ()
 -> Excepts
      '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
        GPGError]
      m
      ())
-> Excepts '[PatchFailed] m ()
-> Excepts
     '[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
       GPGError]
     m
     ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Excepts '[PatchFailed] m ()
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 = [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
forall (m :: * -> *).
MonadIO m =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
exec
  [Char]
"/usr/bin/xattr"
  [[Char]
"-r", [Char]
"-d", [Char]
"com.apple.quarantine", [Char]
path]
  Maybe [Char]
forall a. Maybe a
Nothing
  Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
darwinNotarization Platform
_ [Char]
_ = Either ProcessError () -> m (Either ProcessError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessError () -> m (Either ProcessError ()))
-> Either ProcessError () -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ProcessError ()
forall a b. b -> Either a b
Right ()




getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog GHCupDownloads
dls Tool
tool (GHCVersion GHCTargetVersion
v') =
  Optic' An_AffineTraversal '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     An_AffineTraversal
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
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
% Index (Map GHCTargetVersion VersionInfo)
-> Optic'
     (IxKind (Map GHCTargetVersion VersionInfo))
     '[]
     (Map GHCTargetVersion VersionInfo)
     (IxValue (Map GHCTargetVersion VersionInfo))
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index (Map GHCTargetVersion VersionInfo)
GHCTargetVersion
v' Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: 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
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineTraversal '[] GHCupDownloads URI
forall k l m (is :: 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
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolVersion (Version -> GHCTargetVersion
mkTVer -> GHCTargetVersion
v')) =
  Optic' An_AffineTraversal '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     An_AffineTraversal
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
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
% Index (Map GHCTargetVersion VersionInfo)
-> Optic'
     (IxKind (Map GHCTargetVersion VersionInfo))
     '[]
     (Map GHCTargetVersion VersionInfo)
     (IxValue (Map GHCTargetVersion VersionInfo))
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index (Map GHCTargetVersion VersionInfo)
GHCTargetVersion
v' Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineTraversal
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: 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
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineTraversal '[] GHCupDownloads URI
forall k l m (is :: 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
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolTag Tag
tag) =
  Optic' An_AffineFold '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
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
% Fold
  (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
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) Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (GHCTargetVersion, VersionInfo)
  (GHCTargetVersion, VersionInfo)
-> Optic
     A_Getter
     '[]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
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
% ((GHCTargetVersion, VersionInfo) -> VersionInfo)
-> Optic
     A_Getter
     '[]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
     VersionInfo
     VersionInfo
forall s a. (s -> a) -> Getter s a
to (GHCTargetVersion, VersionInfo) -> VersionInfo
forall a b. (a, b) -> b
snd Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: 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
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineFold '[] GHCupDownloads URI
forall k l m (is :: 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
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolDay Day
day) =
  Optic' An_AffineFold '[] GHCupDownloads URI
-> GHCupDownloads -> Maybe URI
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
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
% Fold
  (Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
-> Optic
     An_AffineFold
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
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) Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (GHCTargetVersion, VersionInfo)
  (GHCTargetVersion, VersionInfo)
-> Optic
     A_Getter
     '[]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
     VersionInfo
     VersionInfo
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
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
% ((GHCTargetVersion, VersionInfo) -> VersionInfo)
-> Optic
     A_Getter
     '[]
     (GHCTargetVersion, VersionInfo)
     (GHCTargetVersion, VersionInfo)
     VersionInfo
     VersionInfo
forall s a. (s -> a) -> Getter s a
to (GHCTargetVersion, VersionInfo) -> VersionInfo
forall a b. (a, b) -> b
snd Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Maybe URI)
     (Maybe URI)
forall k l m (is :: 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
% Optic A_Lens '[] VersionInfo VersionInfo (Maybe URI) (Maybe URI)
viChangeLog Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Maybe URI)
  (Maybe URI)
-> Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
-> Optic' An_AffineFold '[] GHCupDownloads URI
forall k l m (is :: 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
% Optic A_Prism '[] (Maybe URI) (Maybe URI) URI URI
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls


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


-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanUpOnError :: forall e m a env .
                  ( MonadReader env m
                  , HasDirs env
                  , HasSettings env
                  , MonadIO m
                  , MonadMask m
                  , HasLog env
                  , MonadUnliftIO m
                  , MonadFail m
                  , MonadCatch m
                  )
               => GHCupPath        -- ^ build directory (cleaned up depending on Settings)
               -> Excepts e m a
               -> Excepts e m a
cleanUpOnError :: 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
$sel:cache:Settings :: Settings -> Bool
$sel:metaCache:Settings :: Settings -> Integer
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:noVerify:Settings :: Settings -> Bool
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:downloader:Settings :: Settings -> Downloader
$sel:verbose:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:noNetwork:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noColor:Settings :: Settings -> Bool
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:mirrors:Settings :: Settings -> DownloadMirrors
cache :: Bool
metaCache :: Integer
metaMode :: MetaMode
noVerify :: Bool
keepDirs :: KeepDirs
downloader :: Downloader
verbose :: Bool
urlSource :: URLSource
noNetwork :: Bool
gpgSetting :: GPGSetting
noColor :: Bool
platformOverride :: Maybe PlatformRequest
mirrors :: DownloadMirrors
..} <- m Settings -> Excepts e m Settings
forall (m :: * -> *) a. Monad m => m a -> Excepts e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  (Excepts e m a -> Excepts e m () -> Excepts e m a)
-> Excepts e m () -> Excepts e m a -> Excepts e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts e m a -> Excepts e m () -> Excepts e m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (m () -> Excepts e m ()
forall (m :: * -> *) a. Monad m => m a -> Excepts e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) (Excepts e m a -> Excepts e m a) -> Excepts e m a -> Excepts e m a
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m a -> Excepts e m a
forall (m :: * -> *) (es :: 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
$sel:cache:Settings :: Settings -> Bool
$sel:metaCache:Settings :: Settings -> Integer
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:noVerify:Settings :: Settings -> Bool
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:downloader:Settings :: Settings -> Downloader
$sel:verbose:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:noNetwork:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noColor:Settings :: Settings -> Bool
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:mirrors:Settings :: Settings -> DownloadMirrors
cache :: Bool
metaCache :: Integer
metaMode :: MetaMode
noVerify :: Bool
keepDirs :: KeepDirs
downloader :: Downloader
verbose :: Bool
urlSource :: URLSource
noNetwork :: Bool
gpgSetting :: GPGSetting
noColor :: Bool
platformOverride :: Maybe PlatformRequest
mirrors :: DownloadMirrors
..} <- m Settings -> Excepts e m Settings
forall (m :: * -> *) a. Monad m => m a -> Excepts e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  let exAction :: m ()
exAction = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
  (Excepts e m a -> Excepts e m () -> Excepts e m a)
-> Excepts e m () -> Excepts e m a -> Excepts e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts e m a -> Excepts e m () -> Excepts e m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (m () -> Excepts e m ()
forall (m :: * -> *) a. Monad m => m a -> Excepts e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) (Excepts e m a -> Excepts e m a) -> Excepts e m a -> Excepts e m a
forall a b. (a -> b) -> a -> b
$ m () -> Excepts e m a -> Excepts e m a
forall (m :: * -> *) (es :: 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 a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> m () -> IO ()
forall a. m a -> IO a
run (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$
           IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> m () -> IO ()
forall a. m a -> IO a
run (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
               Text
"Couldn't remove build dir " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath GHCupPath
dir) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", error was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e))
           (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
           (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmPathForcibly GHCupPath
dir)


getVersionInfo :: GHCTargetVersion
               -> Tool
               -> GHCupDownloads
               -> Maybe VersionInfo
getVersionInfo :: GHCTargetVersion -> Tool -> GHCupDownloads -> Maybe VersionInfo
getVersionInfo GHCTargetVersion
v' Tool
tool =
  Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  VersionInfo
  VersionInfo
-> GHCupDownloads -> Maybe VersionInfo
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf
    ( Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
tool
    Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
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
% (Map GHCTargetVersion VersionInfo
 -> Map GHCTargetVersion VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
forall s a. (s -> a) -> Getter s a
to ((GHCTargetVersion -> VersionInfo -> Bool)
-> Map GHCTargetVersion VersionInfo
-> Map GHCTargetVersion VersionInfo
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\GHCTargetVersion
k VersionInfo
_ -> GHCTargetVersion
k GHCTargetVersion -> GHCTargetVersion -> Bool
forall a. Eq a => a -> a -> Bool
== GHCTargetVersion
v'))
    Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map GHCTargetVersion VersionInfo)
  (Map GHCTargetVersion VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [VersionInfo]
     [VersionInfo]
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     [VersionInfo]
     [VersionInfo]
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
% (Map GHCTargetVersion VersionInfo -> [VersionInfo])
-> Optic
     A_Getter
     '[]
     (Map GHCTargetVersion VersionInfo)
     (Map GHCTargetVersion VersionInfo)
     [VersionInfo]
     [VersionInfo]
forall s a. (s -> a) -> Getter s a
to Map GHCTargetVersion VersionInfo -> [VersionInfo]
forall k a. Map k a -> [a]
Map.elems
    Optic
  An_AffineFold
  '[]
  GHCupDownloads
  GHCupDownloads
  [VersionInfo]
  [VersionInfo]
-> Optic
     An_AffineTraversal
     '[]
     [VersionInfo]
     [VersionInfo]
     VersionInfo
     VersionInfo
-> Optic
     An_AffineFold
     '[]
     GHCupDownloads
     GHCupDownloads
     VersionInfo
     VersionInfo
forall k l m (is :: 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
% Optic
  An_AffineTraversal
  '[]
  [VersionInfo]
  [VersionInfo]
  VersionInfo
  VersionInfo
forall s a. Cons s s a a => AffineTraversal' s a
_head
    )


ensureGlobalTools :: ( MonadMask m
                     , MonadThrow m
                     , HasLog env
                     , MonadIO m
                     , MonadReader env m
                     , HasDirs env
                     , HasSettings env
                     , HasGHCupInfo env
                     , MonadUnliftIO m
                     , MonadFail m
                     )
                  => Excepts '[GPGError, DigestError, 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) <- m GHCupInfo
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     GHCupInfo
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m GHCupInfo
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
      Dirs
dirs <- m Dirs
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     Dirs
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
      DownloadInfo
shimDownload <- Excepts '[NoDownload] m DownloadInfo
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     DownloadInfo
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NoDownload] m DownloadInfo
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed,
        NoDownload]
      m
      DownloadInfo)
-> Excepts '[NoDownload] m DownloadInfo
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     DownloadInfo
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]
        (Either NoDownload DownloadInfo
 -> Excepts '[NoDownload] m DownloadInfo)
-> Either NoDownload DownloadInfo
-> Excepts '[NoDownload] m DownloadInfo
forall a b. (a -> b) -> a -> b
$ Either NoDownload DownloadInfo
-> (DownloadInfo -> Either NoDownload DownloadInfo)
-> Maybe DownloadInfo
-> Either NoDownload DownloadInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NoDownload -> Either NoDownload DownloadInfo
forall a b. a -> Either a b
Left (GlobalTool -> NoDownload
NoDownload' GlobalTool
ShimGen)) DownloadInfo -> Either NoDownload DownloadInfo
forall a b. b -> Either a b
Right (Maybe DownloadInfo -> Either NoDownload DownloadInfo)
-> Maybe DownloadInfo -> Either NoDownload DownloadInfo
forall a b. (a -> b) -> a -> b
$ GlobalTool -> Map GlobalTool DownloadInfo -> Maybe DownloadInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalTool
ShimGen Map GlobalTool DownloadInfo
gTools
      let dl :: Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
dl = DownloadInfo
-> Maybe [Char]
-> Maybe [Char]
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
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 ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"gs.exe") Maybe [Char]
forall a. Maybe a
Nothing
      Excepts
  '[GPGError, DigestError, ContentLengthError, DownloadFailed,
    NoDownload]
  m
  [Char]
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Excepts
   '[GPGError, DigestError, ContentLengthError, DownloadFailed,
     NoDownload]
   m
   [Char]
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed,
        NoDownload]
      m
      ())
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     [Char]
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     ()
forall a b. (a -> b) -> a -> b
$ (\DigestError{} -> do
          m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ())
-> m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn Text
"Digest doesn't match, redownloading gs.exe..."
          m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ())
-> m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) [Char] -> [Char] -> [Char]
</> [Char]
"gs.exe"))
          m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall (m :: * -> *) a.
Monad m =>
m a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ())
-> m ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
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] (Excepts
   '[DigestError, ContentLengthError, DownloadFailed, GPGError]
   m
   [Char]
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed]
      m
      [Char])
-> Excepts
     '[DigestError, ContentLengthError, DownloadFailed, GPGError]
     m
     [Char]
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed]
     m
     [Char]
forall a b. (a -> b) -> a -> b
$ Excepts
  '[DigestError, ContentLengthError, DownloadFailed, GPGError]
  m
  [Char]
dl
        ) (DigestError
 -> Excepts
      '[GPGError, DigestError, ContentLengthError, DownloadFailed]
      m
      [Char])
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed]
     m
     [Char]
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     [Char]
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 = ()
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     ()
forall a.
a
-> Excepts
     '[GPGError, DigestError, ContentLengthError, DownloadFailed,
       NoDownload]
     m
     a
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)
  () -> IO ()
forall a. a -> IO a
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-ghc" Text -> Text -> Text
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" Text -> Text -> Text
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
  [IOErrorType]
-> () -> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] () (Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ())
-> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
empty' <- IO Bool -> Excepts '[DirNotEmpty] m Bool
forall a. IO a -> Excepts '[DirNotEmpty] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[DirNotEmpty] m Bool)
-> IO Bool -> Excepts '[DirNotEmpty] m Bool
forall a b. (a -> b) -> a -> b
$ SerialT IO [Char] -> IO Bool
forall (m :: * -> *) a. Monad m => SerialT m a -> m Bool
S.null (SerialT IO [Char] -> IO Bool) -> SerialT IO [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> SerialT IO [Char]
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
[Char] -> SerialT m [Char]
getDirectoryContentsRecursiveUnsafe [Char]
isoDir
    Bool -> Excepts '[DirNotEmpty] m () -> Excepts '[DirNotEmpty] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
empty') (DirNotEmpty -> Excepts '[DirNotEmpty] m ()
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (DirNotEmpty -> Excepts '[DirNotEmpty] m ())
-> DirNotEmpty -> Excepts '[DirNotEmpty] m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> DirNotEmpty
DirNotEmpty [Char]
isoDir)
installDestSanityCheck InstallDirResolved
_ = () -> Excepts '[DirNotEmpty] m ()
forall a. a -> Excepts '[DirNotEmpty] m a
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' = [IOErrorType]
-> Maybe [[Char]] -> m (Maybe [[Char]]) -> m (Maybe [[Char]])
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] Maybe [[Char]]
forall a. Maybe a
Nothing (m (Maybe [[Char]]) -> m (Maybe [[Char]]))
-> m (Maybe [[Char]]) -> m (Maybe [[Char]])
forall a b. (a -> b) -> a -> b
$ do
  [Char]
f <- Tool -> GHCTargetVersion -> m [Char]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m [Char]
recordedInstallationFile Tool
t GHCTargetVersion
v'
  ([Char] -> [Char]
forall a. NFData a => a -> a
force -> ![Char]
c) <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    ([Char] -> IO [Char]
readFile [Char]
f IO [Char] -> ([Char] -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO [Char]
forall a. a -> IO a
evaluate)
  Maybe [[Char]] -> m (Maybe [[Char]])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> Maybe [[Char]]
forall a. a -> Maybe a
Just ([[Char]] -> Maybe [[Char]]) -> [[Char]] -> Maybe [[Char]]
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 <- m [Version]
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m,
 MonadThrow m, MonadCatch m) =>
m [Version]
hlsGHCVersions
  Maybe Version
currentGHC   <- (GHCTargetVersion -> Version)
-> Maybe GHCTargetVersion -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHCTargetVersion -> Version
_tvVersion (Maybe GHCTargetVersion -> Maybe Version)
-> m (Maybe GHCTargetVersion) -> m (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> m (Maybe GHCTargetVersion)
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
forall a. Maybe a
Nothing
  Maybe Version
currentHLS   <- m (Maybe Version)
forall env (m :: * -> *).
(HasLog env, MonadReader env m, HasDirs env, MonadIO m,
 MonadThrow m, MonadCatch m) =>
m (Maybe Version)
hlsSet

  case (Maybe Version
currentGHC, Maybe Version
currentHLS) of
    (Just Version
gv, Just Version
hv) | Version
gv Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
supportedGHC -> do
      Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"GHC-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
gv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" appears to have no corresponding HLS-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
hv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" binary." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"Haskell IDE support may not work." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"You can try to either: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"  1. Install a different HLS version (e.g. downgrade for older GHCs)" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"  2. Install and set one of the following GHCs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack ([Version] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [Version]
supportedGHC) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"  3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
hv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --ghc " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
gv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --cabal-update\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"     (see https://www.haskell.org/ghcup/guide/#hls for more information)"

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



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



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


gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[[Char]] -> [Char] -> Excepts '[ProcessError] m Text
gitOut [[Char]]
args [Char]
dir = do
  CapturedProcess {ExitCode
ByteString
_exitCode :: ExitCode
_stdOut :: ByteString
_stdErr :: ByteString
$sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
$sel:_stdOut:CapturedProcess :: CapturedProcess -> ByteString
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
..} <- m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[ProcessError] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess)
-> m CapturedProcess -> Excepts '[ProcessError] m CapturedProcess
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
executeOut [Char]
"git" [[Char]]
args ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
dir)
  case ExitCode
_exitCode of
    ExitCode
ExitSuccess   -> Text -> Excepts '[ProcessError] m Text
forall a. a -> Excepts '[ProcessError] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Excepts '[ProcessError] m Text)
-> Text -> Excepts '[ProcessError] m Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stripNewlineEnd ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
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
      m () -> Excepts '[ProcessError] m ()
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[ProcessError] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[ProcessError] m ())
-> m () -> Excepts '[ProcessError] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (ProcessError -> [Char]
forall e. (Pretty e, HFErrorProject e) => e -> [Char]
prettyHFError ProcessError
pe)
      ProcessError -> Excepts '[ProcessError] m Text
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'   = ([Char] -> [[Char]]) -> [[Char]] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [[Char]]
words [[Char]]
lines'
                           refs :: [[Char]]
refs     = [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> Maybe [Char]) -> [[[Char]]] -> [Maybe [Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Char]] -> Int -> Maybe [Char]
forall a. [a] -> Int -> Maybe a
`atMay` Int
1) [[[Char]]]
words'
                           branches :: [[Char]]
branches = [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe [Char]) -> [[Char]] -> [Maybe [Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"refs/heads/") ([[Char]] -> [Maybe [Char]]) -> [[Char]] -> [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"refs/heads/") [[Char]]
refs
                       in [[Char]]
branches