{-# 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.Tar
  , module GHCup.Utils
  , module GHCup.Utils.URI
#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.Utils.Tar
import           GHCup.Utils.URI
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           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 hiding (parseURI)

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 Data.Versions
-- >>> 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 $ GHCup.Utils.parseURI $ "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) >>= liftE . decodeMetadata @GHCupInfo



    ------------------------
    --[ 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
msys2Dir :: [Char]
$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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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 version 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..} <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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
$sel:msys2Dir:Dirs :: Dirs -> [Char]
baseDir :: GHCupPath
binDir :: [Char]
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: [Char]
..}  <- 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



    ------------
    --[ 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
_viPreInstall :: Maybe Text
_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:_viPreInstall:VersionInfo :: VersionInfo -> Maybe Text
$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:_viPreInstall:VersionInfo :: VersionInfo -> Maybe Text
$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
_viPreInstall :: Maybe Text
_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:_viPreInstall:VersionInfo :: VersionInfo -> Maybe Text
$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
_viPreInstall :: Maybe Text
_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 ]--
    -------------


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

-- | 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])] -> [([Char], [Char])])
-> [[([Char], [Char])]] -> [([Char], [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((([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))

  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


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


ensureShimGen :: ( 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 ()
ensureShimGen :: 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
  ()
ensureShimGen
  | Bool
isWindows = do
      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
      let shimDownload :: DownloadInfo
shimDownload = URI
-> Maybe TarDir
-> Text
-> Maybe Integer
-> Maybe [Char]
-> DownloadInfo
DownloadInfo URI
shimGenURL Maybe TarDir
forall a. Maybe a
Nothing Text
shimGenSHA Maybe Integer
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing
      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 [Char]
_) = 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



    ------------------
    --[ Versioning ]--
    ------------------


-- | Expand a list of version patterns describing a string such as "%v-%h".
--
-- >>> expandVersionPattern (either (const Nothing) Just $ version "3.4.3") "a386748" "a3867484ccc391daad1a42002c3a2ba6a93c5221" "v0.1.20.0-119-ga386748" "issue-998" [CabalVer, S "-", GitHashShort, S "-", GitHashLong, S "-", GitBranchName, S "-", GitDescribe, S "-coco"]
-- Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 3 :| [Numeric 4,Numeric 3]), _vRel = Just (Release (Alphanum "a386748-a3867484ccc391daad1a42002c3a2ba6a93c5221-issue-998-v0" :| [Numeric 1,Numeric 20,Alphanum "0-119-ga386748-coco"])), _vMeta = Nothing}
expandVersionPattern :: MonadFail m
                     => Maybe Version  -- ^ cabal ver
                     -> String         -- ^ git hash (short), if any
                     -> String         -- ^ git hash (long), if any
                     -> String         -- ^ git describe output, if any
                     -> String         -- ^ git branch name, if any
                     -> [VersionPattern]
                     -> m Version
expandVersionPattern :: forall (m :: * -> *).
MonadFail m =>
Maybe Version
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [VersionPattern]
-> m Version
expandVersionPattern Maybe Version
cabalVer [Char]
gitHashS [Char]
gitHashL [Char]
gitDescribe [Char]
gitBranch
  = (ParseErrorBundle Text Void -> m Version)
-> (Version -> m Version)
-> Either (ParseErrorBundle Text Void) Version
-> m Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m Version
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m Version)
-> (ParseErrorBundle Text Void -> [Char])
-> ParseErrorBundle Text Void
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> [Char]
forall e. Exception e => e -> [Char]
displayException) Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle Text Void) Version -> m Version)
-> ([VersionPattern]
    -> Either (ParseErrorBundle Text Void) Version)
-> [VersionPattern]
-> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> ([VersionPattern] -> Text)
-> [VersionPattern]
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text)
-> ([VersionPattern] -> [Char]) -> [VersionPattern] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VersionPattern] -> [Char]
go
 where
  go :: [VersionPattern] -> [Char]
go [] = [Char]
""
  go (VersionPattern
CabalVer:[VersionPattern]
xs) = Text -> [Char]
T.unpack (Text -> (Version -> Text) -> Maybe Version -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Version -> Text
prettyVer Maybe Version
cabalVer) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs
  go (VersionPattern
GitHashShort:[VersionPattern]
xs) = [Char]
gitHashS [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs
  go (VersionPattern
GitHashLong:[VersionPattern]
xs) = [Char]
gitHashL [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs
  go (VersionPattern
GitDescribe:[VersionPattern]
xs) = [Char]
gitDescribe [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs
  go (VersionPattern
GitBranchName:[VersionPattern]
xs) = [Char]
gitBranch [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs
  go (S [Char]
str:[VersionPattern]
xs) = [Char]
str [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [VersionPattern] -> [Char]
go [VersionPattern]
xs