{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# 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 : POSIX

This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
module GHCup.Utils
  ( module GHCup.Utils.Dirs
  , module GHCup.Utils
  )
where


import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.Optics
import           GHCup.Types.JSON               ( )
import           GHCup.Utils.Dirs
import           GHCup.Utils.File
import           GHCup.Utils.MegaParsec
import           GHCup.Utils.Prelude
import           GHCup.Utils.String.QQ

#if !defined(TAR)
import           Codec.Archive           hiding ( Directory )
#endif
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.Logger
import           Control.Monad.Reader
import           Data.ByteString                ( ByteString )
import           Data.Either
import           Data.Foldable
import           Data.List
import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
import           Data.List.Split
import           Data.Maybe
import           Data.String.Interpolate
import           Data.Text                      ( Text )
import           Data.Versions
import           Data.Word8
import           GHC.IO.Exception
import           HPath
import           HPath.IO                hiding ( hideError )
import           Haskus.Utils.Variant.Excepts
import           Optics
import           Prelude                 hiding ( abs
                                                , readFile
                                                , writeFile
                                                )
import           Safe
import           System.IO.Error
import           System.Posix.FilePath          ( getSearchPath
                                                , takeFileName
                                                )
import           System.Posix.Files.ByteString  ( readSymbolicLink )
import           Text.Regex.Posix
import           URI.ByteString

#if defined(TAR)
import qualified Codec.Archive.Tar             as Tar
#endif
import qualified Codec.Compression.BZip        as BZip
import qualified Codec.Compression.GZip        as GZip
import qualified Codec.Compression.Lzma        as Lzma
import qualified Data.ByteString               as B
import qualified Data.ByteString.Lazy          as BL
import qualified Data.Map.Strict               as Map
#if !defined(TAR)
import qualified Data.Text                     as T
#endif
import qualified Data.Text.Encoding            as E
import qualified Text.Megaparsec               as MP





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


-- | The symlink destination of a ghc tool.
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
                   => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
                   -> GHCTargetVersion
                   -> m ByteString
ghcLinkDestination :: ByteString -> GHCTargetVersion -> m ByteString
ghcLinkDestination ByteString
tool GHCTargetVersion
ver = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Rel
t <- ByteString -> m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel ByteString
tool
  Path Abs
ghcd <- GHCTargetVersion -> m (Path Abs)
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m) =>
GHCTargetVersion -> m (Path Abs)
ghcupGHCDir GHCTargetVersion
ver
  ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs -> Path Abs -> ByteString
relativeSymlink Path Abs
binDir (Path Abs
ghcd Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|bin|] Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
t))


-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: ( MonadReader AppState m
                   , MonadIO m
                   , MonadLogger m
                   , MonadThrow m
                   , MonadFail m
                   , MonadReader AppState m
                   )
                => GHCTargetVersion
                -> Excepts '[NotInstalled] m ()
rmMinorSymlinks :: GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
_tvVersion :: GHCTargetVersion -> Version
_tvTarget :: GHCTargetVersion -> Maybe Text
_tvVersion :: Version
_tvTarget :: Maybe Text
..} = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState -> Excepts '[NotInstalled] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask

  [Path Rel]
files                         <- Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [Path Rel]
 -> Excepts '[NotInstalled] m [Path Rel])
-> Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles GHCTargetVersion
tv
  [Path Rel]
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Rel]
files ((Path Rel -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \Path Rel
f -> do
    Path Rel
f_xyz <- IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel))
-> IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
f ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
_hyphen ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
verToBS Version
_tvVersion)
    let fullF :: Path Abs
fullF = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
f_xyz
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|rm -f #{toFilePath fullF}|]
    IO () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[NotInstalled] m ())
-> IO () -> Excepts '[NotInstalled] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
fullF


-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader AppState m
           , MonadLogger m
           , MonadThrow m
           , MonadFail m
           , MonadIO m
           )
        => Maybe Text -- ^ target
        -> Excepts '[NotInstalled] m ()
rmPlain :: Maybe Text -> Excepts '[NotInstalled] m ()
rmPlain Maybe Text
target = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState -> Excepts '[NotInstalled] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe GHCTargetVersion
mtv                           <- m (Maybe GHCTargetVersion)
-> Excepts '[NotInstalled] m (Maybe GHCTargetVersion)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe GHCTargetVersion)
 -> Excepts '[NotInstalled] m (Maybe GHCTargetVersion))
-> m (Maybe GHCTargetVersion)
-> Excepts '[NotInstalled] m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ Maybe Text -> m (Maybe GHCTargetVersion)
forall (m :: * -> *).
(MonadReader AppState m, 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
    [Path Rel]
files <- Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [Path Rel]
 -> Excepts '[NotInstalled] m [Path Rel])
-> Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles GHCTargetVersion
tv
    [Path Rel]
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Rel]
files ((Path Rel -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \Path Rel
f -> do
      let fullF :: Path Abs
fullF = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
f
      m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|rm -f #{toFilePath fullF}|]
      IO () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[NotInstalled] m ())
-> IO () -> Excepts '[NotInstalled] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
fullF
    -- old ghcup
    let hdc_file :: Path Abs
hdc_file = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|haddock-ghc|]
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|rm -f #{toFilePath hdc_file}|]
    IO () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[NotInstalled] m ())
-> IO () -> Excepts '[NotInstalled] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
hdc_file


-- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: ( MonadReader AppState m
                   , MonadIO m
                   , MonadLogger m
                   , MonadThrow m
                   , MonadFail m
                   , MonadReader AppState m
                   )
                => GHCTargetVersion
                -> Excepts '[NotInstalled] m ()
rmMajorSymlinks :: GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
_tvVersion :: GHCTargetVersion -> Version
_tvTarget :: GHCTargetVersion -> Maybe Text
..} = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState -> Excepts '[NotInstalled] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Int
mj, Int
mi) <- Version -> Excepts '[NotInstalled] m CharPos
forall (m :: * -> *). MonadThrow m => Version -> m CharPos
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

  [Path Rel]
files                         <- Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[NotInstalled] m [Path Rel]
 -> Excepts '[NotInstalled] m [Path Rel])
-> Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles GHCTargetVersion
tv
  [Path Rel]
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Rel]
files ((Path Rel -> Excepts '[NotInstalled] m ())
 -> Excepts '[NotInstalled] m ())
-> (Path Rel -> Excepts '[NotInstalled] m ())
-> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ \Path Rel
f -> do
    Path Rel
f_xyz <- IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel))
-> IO (Path Rel) -> Excepts '[NotInstalled] m (Path Rel)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
f ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
_hyphen ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 Text
v')
    let fullF :: Path Abs
fullF = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
f_xyz
    m () -> Excepts '[NotInstalled] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[NotInstalled] m ())
-> m () -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|rm -f #{toFilePath fullF}|]
    IO () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[NotInstalled] m ())
-> IO () -> Excepts '[NotInstalled] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
fullF




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


-- | Whethe the given GHC versin is installed.
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled :: GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver = do
  Path Abs
ghcdir <- GHCTargetVersion -> m (Path Abs)
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m) =>
GHCTargetVersion -> m (Path Abs)
ghcupGHCDir GHCTargetVersion
ver
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
forall b. Path b -> IO Bool
doesDirectoryExist Path Abs
ghcdir


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


-- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
       => Maybe Text   -- ^ the target of the GHC version, if any
                       --  (e.g. armv7-unknown-linux-gnueabihf)
       -> m (Maybe GHCTargetVersion)
ghcSet :: Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
mtarget = do
  AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Rel
ghc    <- ByteString -> m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel (ByteString -> m (Path Rel)) -> ByteString -> m (Path Rel)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
E.encodeUtf8 (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"ghc" (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-ghc") Maybe Text
mtarget)
  let ghcBin :: Path Abs
ghcBin = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
ghc

  -- link destination is of the form ../ghc/<ver>/bin/ghc
  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
  IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion) -> m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion)
-> IO (Maybe GHCTargetVersion)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe GHCTargetVersion -> IO (Maybe GHCTargetVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GHCTargetVersion
forall a. Maybe a
Nothing) (IO (Maybe GHCTargetVersion) -> IO (Maybe GHCTargetVersion))
-> IO (Maybe GHCTargetVersion) -> IO (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
link <- ByteString -> IO ByteString
readSymbolicLink (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
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
<$> ByteString -> IO GHCTargetVersion
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m GHCTargetVersion
ghcLinkVersion ByteString
link

ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion :: ByteString -> m GHCTargetVersion
ghcLinkVersion ByteString
bs = do
  Text
t <- Either UnicodeException Text -> m Text
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either UnicodeException Text -> m Text)
-> Either UnicodeException Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
E.decodeUtf8' ByteString
bs
  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
-> String
-> Text
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text GHCTargetVersion
parser String
"ghcLinkVersion" Text
t
 where
  parser :: Parsec Void Text GHCTargetVersion
parser =
      (do
         Text
_    <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (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/")
         Text
_    <- 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/"
         Text
r    <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (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
"/")
         Text
rest <- Parsec Void Text Text
forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
         Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
r
         GHCTargetVersion
x <- Parsec Void Text GHCTargetVersion
ghcTargetVerP
         Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
         GHCTargetVersion -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
x
       )
      Parsec Void Text GHCTargetVersion
-> Parsec Void Text Text -> Parsec Void Text GHCTargetVersion
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
"/"
      Parsec Void Text GHCTargetVersion
-> Parsec Void Text Text -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec Void Text Text
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
MP.takeRest
      Parsec Void Text GHCTargetVersion
-> ParsecT Void Text Identity ()
-> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof


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


-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
                   => m [Either (Path Rel) Version]
getInstalledCabals :: m [Either (Path Rel) Version]
getInstalledCabals = do
  Maybe Version
cs <- m (Maybe Version)
forall (m :: * -> *).
(MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m,
 MonadCatch m) =>
m (Maybe Version)
cabalSet -- for legacy cabal
  Maybe Version -> m [Either (Path Rel) Version]
forall (m :: * -> *).
(MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) =>
Maybe Version -> m [Either (Path Rel) Version]
getInstalledCabals' Maybe Version
cs


getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
                   => Maybe Version
                   -> m [Either (Path Rel) Version]
getInstalledCabals' :: Maybe Version -> m [Either (Path Rel) Version]
getInstalledCabals' Maybe Version
cs = do
  AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  [Path Rel]
bins   <- IO [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> m [Path Rel]) -> IO [Path Rel] -> m [Path Rel]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [Path Rel] -> IO [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [Path Rel] -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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 (Path Rel) Version]
vs <- [Path Rel]
-> (Path Rel -> m (Either (Path Rel) Version))
-> m [Either (Path Rel) Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Rel]
bins ((Path Rel -> m (Either (Path Rel) Version))
 -> m [Either (Path Rel) Version])
-> (Path Rel -> m (Either (Path Rel) Version))
-> m [Either (Path Rel) Version]
forall a b. (a -> b) -> a -> b
$ \Path Rel
f -> case (ByteString -> Either (ParseErrorBundle Text Void) Version)
-> Maybe ByteString
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> (ByteString -> Text)
-> ByteString
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe) (Maybe ByteString
 -> Maybe (Either (ParseErrorBundle Text Void) Version))
-> (Path Rel -> Maybe ByteString)
-> Path Rel
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"cabal-" (ByteString -> Maybe ByteString)
-> (Path Rel -> ByteString) -> Path Rel -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> Maybe (Either (ParseErrorBundle Text Void) Version))
-> Path Rel -> Maybe (Either (ParseErrorBundle Text Void) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel
f of
    Just (Right Version
r) -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either (Path Rel) Version
forall a b. b -> Either a b
Right Version
r
    Just (Left  ParseErrorBundle Text Void
_) -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel -> Either (Path Rel) Version
forall a b. a -> Either a b
Left Path Rel
f
    Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel -> Either (Path Rel) Version
forall a b. a -> Either a b
Left Path Rel
f
  [Either (Path Rel) Version] -> m [Either (Path Rel) Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either (Path Rel) Version] -> m [Either (Path Rel) Version])
-> [Either (Path Rel) Version] -> m [Either (Path Rel) Version]
forall a b. (a -> b) -> a -> b
$ [Either (Path Rel) Version]
-> (Version -> [Either (Path Rel) Version])
-> Maybe Version
-> [Either (Path Rel) Version]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Either (Path Rel) Version]
vs (\Version
x -> [Either (Path Rel) Version] -> [Either (Path Rel) Version]
forall a. Eq a => [a] -> [a]
nub ([Either (Path Rel) Version] -> [Either (Path Rel) Version])
-> [Either (Path Rel) Version] -> [Either (Path Rel) Version]
forall a b. (a -> b) -> a -> b
$ Version -> Either (Path Rel) Version
forall a b. b -> Either a b
Right Version
xEither (Path Rel) Version
-> [Either (Path Rel) Version] -> [Either (Path Rel) Version]
forall a. a -> [a] -> [a]
:[Either (Path Rel) Version]
vs) Maybe Version
cs


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


-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: m (Maybe Version)
cabalSet = do
  AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  let cabalbin :: Path Abs
cabalbin = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|cabal|]
  Bool
b        <- (IOException -> m Bool) -> m Bool -> m Bool
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (FileType -> Bool) -> m FileType -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileType -> FileType -> Bool
forall a. Eq a => a -> a -> Bool
== FileType
SymbolicLink) (m FileType -> m Bool) -> m FileType -> m Bool
forall a b. (a -> b) -> a -> b
$ IO FileType -> m FileType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileType -> m FileType) -> IO FileType -> m FileType
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO FileType
forall b. Path b -> IO FileType
getFileType Path Abs
cabalbin
  if
    | Bool
b -> do
      IOErrorType
-> (IOException -> m (Maybe Version))
-> m (Maybe Version)
-> m (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (m (Maybe Version) -> m (Maybe Version))
-> m (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
        Bool
broken <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
isBrokenSymlink Path Abs
cabalbin
        if Bool
broken
          then do
            $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logWarn) [i|Symlink #{cabalbin} is broken.|]
            Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
          else do
            ByteString
link <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
readSymbolicLink (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
cabalbin
            case ByteString -> Either SomeException Version
forall (m :: * -> *). MonadThrow m => ByteString -> m Version
linkVersion ByteString
link of
              Right Version
v -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Version -> m (Maybe Version))
-> Maybe Version -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
              Left SomeException
err -> do
                $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
                Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
    | Bool
otherwise -> do -- legacy behavior
      Maybe CapturedProcess
mc <- IO (Maybe CapturedProcess) -> m (Maybe CapturedProcess)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CapturedProcess) -> m (Maybe CapturedProcess))
-> IO (Maybe CapturedProcess) -> m (Maybe CapturedProcess)
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Maybe CapturedProcess))
-> IO (Maybe CapturedProcess) -> IO (Maybe CapturedProcess)
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> Maybe CapturedProcess -> IO (Maybe CapturedProcess)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CapturedProcess
forall a. Maybe a
Nothing) (IO (Maybe CapturedProcess) -> IO (Maybe CapturedProcess))
-> IO (Maybe CapturedProcess) -> IO (Maybe CapturedProcess)
forall a b. (a -> b) -> a -> b
$ (CapturedProcess -> Maybe CapturedProcess)
-> IO CapturedProcess -> IO (Maybe CapturedProcess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CapturedProcess -> Maybe CapturedProcess
forall a. a -> Maybe a
Just (IO CapturedProcess -> IO (Maybe CapturedProcess))
-> IO CapturedProcess -> IO (Maybe CapturedProcess)
forall a b. (a -> b) -> a -> b
$ Path Abs -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
forall b.
Path b -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
executeOut
        Path Abs
cabalbin
        [ByteString
"--numeric-version"]
        Maybe (Path Abs)
forall a. Maybe a
Nothing
      (Maybe (Maybe Version) -> Maybe Version)
-> m (Maybe (Maybe Version)) -> m (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe Version) -> Maybe Version
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (Maybe (Maybe Version)) -> m (Maybe Version))
-> m (Maybe (Maybe Version)) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Maybe CapturedProcess
-> (CapturedProcess -> m (Maybe Version))
-> m (Maybe (Maybe Version))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe CapturedProcess
mc ((CapturedProcess -> m (Maybe Version))
 -> m (Maybe (Maybe Version)))
-> (CapturedProcess -> m (Maybe Version))
-> m (Maybe (Maybe Version))
forall a b. (a -> b) -> a -> b
$ \CapturedProcess
c -> if
        | Bool -> Bool
not (ByteString -> Bool
B.null (CapturedProcess -> ByteString
_stdOut CapturedProcess
c)), CapturedProcess -> ExitCode
_exitCode CapturedProcess
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess -> do
          let reportedVer :: ByteString
reportedVer = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (CapturedProcess -> (ByteString, ByteString))
-> CapturedProcess
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.spanEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf) (ByteString -> (ByteString, ByteString))
-> (CapturedProcess -> ByteString)
-> CapturedProcess
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CapturedProcess -> ByteString
_stdOut (CapturedProcess -> ByteString) -> CapturedProcess -> ByteString
forall a b. (a -> b) -> a -> b
$ CapturedProcess
c
          case Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> Text -> Either (ParseErrorBundle Text Void) Version
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe ByteString
reportedVer of
            Left  ParseErrorBundle Text Void
e -> ParseErrorBundle Text Void -> m (Maybe Version)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ParseErrorBundle Text Void
e
            Right Version
r -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Version -> m (Maybe Version))
-> Maybe Version -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
r
        | Bool
otherwise -> Maybe Version -> m (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
 where
  -- We try to be extra permissive with link destination parsing,
  -- because of:
  --   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
  linkVersion :: MonadThrow m => ByteString -> m Version
  linkVersion :: ByteString -> m Version
linkVersion ByteString
bs = do
    Text
t <- Either UnicodeException Text -> m Text
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either UnicodeException Text -> m Text)
-> Either UnicodeException Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
E.decodeUtf8' ByteString
bs
    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)
-> Either (ParseErrorBundle Text Void) Version -> m Version
forall a b. (a -> b) -> a -> b
$ Parsec Void Text Version
-> String -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser String
"" Text
t

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



-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
                 => m [Either (Path Rel) Version]
getInstalledHLSs :: m [Either (Path Rel) Version]
getInstalledHLSs = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  [Path Rel]
bins                          <- IO [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> m [Path Rel]) -> IO [Path Rel] -> m [Path Rel]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [Path Rel] -> IO [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [Path Rel] -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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)
    )
  [Path Rel]
-> (Path Rel -> m (Either (Path Rel) Version))
-> m [Either (Path Rel) Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Rel]
bins ((Path Rel -> m (Either (Path Rel) Version))
 -> m [Either (Path Rel) Version])
-> (Path Rel -> m (Either (Path Rel) Version))
-> m [Either (Path Rel) Version]
forall a b. (a -> b) -> a -> b
$ \Path Rel
f ->
    case
          (ByteString -> Either (ParseErrorBundle Text Void) Version)
-> Maybe ByteString
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Either (ParseErrorBundle Text Void) Version
version (Text -> Either (ParseErrorBundle Text Void) Version)
-> (ByteString -> Text)
-> ByteString
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe) (Maybe ByteString
 -> Maybe (Either (ParseErrorBundle Text Void) Version))
-> (Path Rel -> Maybe ByteString)
-> Path Rel
-> Maybe (Either (ParseErrorBundle Text Void) Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"haskell-language-server-wrapper-" (ByteString -> Maybe ByteString)
-> (Path Rel -> ByteString) -> Path Rel -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> Maybe (Either (ParseErrorBundle Text Void) Version))
-> Path Rel -> Maybe (Either (ParseErrorBundle Text Void) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel
f
      of
        Just (Right Version
r) -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Version -> Either (Path Rel) Version
forall a b. b -> Either a b
Right Version
r
        Just (Left  ParseErrorBundle Text Void
_) -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel -> Either (Path Rel) Version
forall a b. a -> Either a b
Left Path Rel
f
        Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing        -> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Rel) Version -> m (Either (Path Rel) Version))
-> Either (Path Rel) Version -> m (Either (Path Rel) Version)
forall a b. (a -> b) -> a -> b
$ Path Rel -> Either (Path Rel) Version
forall a b. a -> Either a b
Left Path Rel
f


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



-- Return the currently set hls version, if any.
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet :: m (Maybe Version)
hlsSet = do
  AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  let hlsBin :: Path Abs
hlsBin = Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|haskell-language-server-wrapper|]

  IO (Maybe Version) -> m (Maybe Version)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Maybe Version))
-> IO (Maybe Version)
-> IO (Maybe Version)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe Version -> IO (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing) (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
    Bool
broken <- Path Abs -> IO Bool
isBrokenSymlink Path Abs
hlsBin
    if Bool
broken
      then Maybe Version -> IO (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
      else do
        ByteString
link <- ByteString -> IO ByteString
readSymbolicLink (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
hlsBin
        Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> IO Version -> IO (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO Version
forall (m :: * -> *). MonadThrow m => ByteString -> m Version
linkVersion ByteString
link
 where
  linkVersion :: MonadThrow m => ByteString -> m Version
  linkVersion :: ByteString -> m Version
linkVersion ByteString
bs = do
    Text
t <- Either UnicodeException Text -> m Text
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either UnicodeException Text -> m Text)
-> Either UnicodeException Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
E.decodeUtf8' ByteString
bs
    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)
-> Either (ParseErrorBundle Text Void) Version -> m Version
forall a b. (a -> b) -> a -> b
$ Parsec Void Text Version
-> String -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
parser String
"" Text
t
   where
    parser :: Parsec Void Text Version
parser =
      Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-wrapper-" Parsec Void Text Text
-> Parsec Void Text Version -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Version
version'


-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader AppState m
                  , MonadIO m
                  , MonadThrow m
                  , MonadCatch m
                  )
               => m [Version]
hlsGHCVersions :: m [Version]
hlsGHCVersions = do
  Maybe Version
h                             <- m (Maybe Version)
forall (m :: * -> *).
(MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) =>
m (Maybe Version)
hlsSet
  Maybe [Either (ParseErrorBundle Text Void) Version]
vers                          <- Maybe Version
-> (Version -> m [Either (ParseErrorBundle Text Void) Version])
-> m (Maybe [Either (ParseErrorBundle Text Void) Version])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Version
h ((Version -> m [Either (ParseErrorBundle Text Void) Version])
 -> m (Maybe [Either (ParseErrorBundle Text Void) Version]))
-> (Version -> m [Either (ParseErrorBundle Text Void) Version])
-> m (Maybe [Either (ParseErrorBundle Text Void) Version])
forall a b. (a -> b) -> a -> b
$ \Version
h' -> do
    [Path Rel]
bins <- Version -> m [Path Rel]
forall (m :: * -> *).
(MonadReader AppState m, MonadIO m) =>
Version -> m [Path Rel]
hlsServerBinaries Version
h'
    [Either (ParseErrorBundle Text Void) Version]
-> m [Either (ParseErrorBundle Text Void) Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either (ParseErrorBundle Text Void) Version]
 -> m [Either (ParseErrorBundle Text Void) Version])
-> [Either (ParseErrorBundle Text Void) Version]
-> m [Either (ParseErrorBundle Text Void) Version]
forall a b. (a -> b) -> a -> b
$ (Path Rel -> Either (ParseErrorBundle Text Void) Version)
-> [Path Rel] -> [Either (ParseErrorBundle Text Void) Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (Text -> Either (ParseErrorBundle Text Void) Version
version
        (Text -> Either (ParseErrorBundle Text Void) Version)
-> (Path Rel -> Text)
-> Path Rel
-> Either (ParseErrorBundle Text Void) Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe
        (ByteString -> Text)
-> (Path Rel -> ByteString) -> Path Rel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust
        (Maybe ByteString -> ByteString)
-> (Path Rel -> Maybe ByteString) -> Path Rel -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"haskell-language-server-"
        (ByteString -> Maybe ByteString)
-> (Path Rel -> ByteString) -> Path Rel -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. [a] -> a
head
        ([ByteString] -> ByteString)
-> (Path Rel -> [ByteString]) -> Path Rel -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
B.split Word8
_tilde
        (ByteString -> [ByteString])
-> (Path Rel -> ByteString) -> Path Rel -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath
      )
      [Path Rel]
bins
  [Version] -> m [Version]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Version] -> m [Version])
-> (Maybe [Either (ParseErrorBundle Text Void) Version]
    -> [Version])
-> Maybe [Either (ParseErrorBundle Text Void) Version]
-> m [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] -> [Version])
-> (Maybe [Either (ParseErrorBundle Text Void) Version]
    -> [Either (ParseErrorBundle Text Void) Version])
-> Maybe [Either (ParseErrorBundle Text Void) Version]
-> [Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either (ParseErrorBundle Text Void) Version]]
-> [Either (ParseErrorBundle Text Void) Version]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either (ParseErrorBundle Text Void) Version]]
 -> [Either (ParseErrorBundle Text Void) Version])
-> (Maybe [Either (ParseErrorBundle Text Void) Version]
    -> [[Either (ParseErrorBundle Text Void) Version]])
-> Maybe [Either (ParseErrorBundle Text Void) Version]
-> [Either (ParseErrorBundle Text Void) Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Either (ParseErrorBundle Text Void) Version]
-> [[Either (ParseErrorBundle Text Void) Version]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Either (ParseErrorBundle Text Void) Version]
 -> m [Version])
-> Maybe [Either (ParseErrorBundle Text Void) Version]
-> m [Version]
forall a b. (a -> b) -> a -> b
$ Maybe [Either (ParseErrorBundle Text Void) Version]
vers


-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
                  => Version
                  -> m [Path Rel]
hlsServerBinaries :: Version -> m [Path Rel]
hlsServerBinaries Version
ver = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> m [Path Rel]) -> IO [Path Rel] -> m [Path Rel]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [Path Rel] -> IO [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [Path Rel] -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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
<> Version -> ByteString
escapeVerRex Version
ver ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
      )
    )


-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
                 => Version
                 -> m (Maybe (Path Rel))
hlsWrapperBinary :: Version -> m (Maybe (Path Rel))
hlsWrapperBinary Version
ver = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  [Path Rel]
wrapper                       <- IO [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> m [Path Rel]) -> IO [Path Rel] -> m [Path Rel]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [Path Rel] -> IO [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [Path Rel] -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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
<> [s|$|] :: ByteString
      )
    )
  case [Path Rel]
wrapper of
    []  -> Maybe (Path Rel) -> m (Maybe (Path Rel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Rel)
forall a. Maybe a
Nothing
    [Path Rel
x] -> Maybe (Path Rel) -> m (Maybe (Path Rel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Rel) -> m (Maybe (Path Rel)))
-> Maybe (Path Rel) -> m (Maybe (Path Rel))
forall a b. (a -> b) -> a -> b
$ Path Rel -> Maybe (Path Rel)
forall a. a -> Maybe a
Just Path Rel
x
    [Path Rel]
_   -> UnexpectedListLength -> m (Maybe (Path Rel))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedListLength -> m (Maybe (Path Rel)))
-> UnexpectedListLength -> m (Maybe (Path Rel))
forall a b. (a -> b) -> a -> b
$ String -> UnexpectedListLength
UnexpectedListLength
      String
"There were multiple hls wrapper binaries for a single version"


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


-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks :: m [Path Rel]
hlsSymlinks = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  [Path Rel]
oldSyms                       <- IO [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> m [Path Rel]) -> IO [Path Rel] -> m [Path Rel]
forall a b. (a -> b) -> a -> b
$ (IOException -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [Path Rel] -> IO [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [Path Rel] -> IO [Path Rel]) -> IO [Path Rel] -> IO [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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)
    )
  (Path Rel -> m Bool) -> [Path Rel] -> m [Path Rel]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
    ( (FileType -> Bool) -> m FileType -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileType -> FileType -> Bool
forall a. Eq a => a -> a -> Bool
== FileType
SymbolicLink)
    (m FileType -> m Bool)
-> (Path Rel -> m FileType) -> Path Rel -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FileType -> m FileType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO FileType -> m FileType)
-> (Path Rel -> IO FileType) -> Path Rel -> m FileType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs -> IO FileType
forall b. Path b -> IO FileType
getFileType
    (Path Abs -> IO FileType)
-> (Path Rel -> Path Abs) -> Path Rel -> IO FileType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs
binDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</>)
    )
    [Path Rel]
oldSyms



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


-- | Extract (major, minor) from any version.
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV :: Version -> m CharPos
getMajorMinorV Version {[VChunk]
Maybe Word
NonEmpty VChunk
_vEpoch :: Version -> Maybe Word
_vChunks :: Version -> NonEmpty VChunk
_vMeta :: Version -> [VChunk]
_vRel :: Version -> [VChunk]
_vRel :: [VChunk]
_vMeta :: [VChunk]
_vChunks :: NonEmpty VChunk
_vEpoch :: Maybe Word
..} = case NonEmpty VChunk
_vChunks of
  ((Digits Word
x :| []) :| ((Digits Word
y :| []):[VChunk]
_)) -> CharPos -> m CharPos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
y)
  NonEmpty VChunk
_ -> ParseError -> m CharPos
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m CharPos) -> ParseError -> m CharPos
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"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 CharPos
forall (m :: * -> *). MonadThrow m => Version -> m CharPos
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 CharPos
Nothing     -> Bool
False


-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
               => Int        -- ^ major version component
               -> Int        -- ^ minor version component
               -> Maybe Text -- ^ the target triple
               -> m (Maybe GHCTargetVersion)
getGHCForMajor :: Int -> Int -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForMajor Int
major' Int
minor' Maybe Text
mt = do
  [GHCTargetVersion]
ghcs <- [Either (Path Rel) GHCTargetVersion] -> [GHCTargetVersion]
forall a b. [Either a b] -> [b]
rights ([Either (Path Rel) GHCTargetVersion] -> [GHCTargetVersion])
-> m [Either (Path Rel) GHCTargetVersion] -> m [GHCTargetVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Either (Path Rel) GHCTargetVersion]
forall (m :: * -> *).
(MonadReader AppState m, MonadIO m) =>
m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs

  Maybe GHCTargetVersion -> m (Maybe GHCTargetVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe GHCTargetVersion -> m (Maybe GHCTargetVersion))
-> ([GHCTargetVersion] -> Maybe GHCTargetVersion)
-> [GHCTargetVersion]
-> m (Maybe GHCTargetVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GHCTargetVersion] -> Maybe GHCTargetVersion
forall a. [a] -> Maybe a
lastMay
    ([GHCTargetVersion] -> Maybe GHCTargetVersion)
-> ([GHCTargetVersion] -> [GHCTargetVersion])
-> [GHCTargetVersion]
-> Maybe GHCTargetVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GHCTargetVersion -> GHCTargetVersion -> Ordering)
-> [GHCTargetVersion] -> [GHCTargetVersion]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\GHCTargetVersion
x GHCTargetVersion
y -> Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
x) (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
y))
    ([GHCTargetVersion] -> [GHCTargetVersion])
-> ([GHCTargetVersion] -> [GHCTargetVersion])
-> [GHCTargetVersion]
-> [GHCTargetVersion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GHCTargetVersion -> Bool)
-> [GHCTargetVersion] -> [GHCTargetVersion]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (\GHCTargetVersion {Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
_tvVersion :: GHCTargetVersion -> Version
_tvTarget :: GHCTargetVersion -> Maybe Text
..} ->
          Maybe Text
_tvTarget Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
mt Bool -> Bool -> Bool
&& Version -> Int -> Int -> Bool
matchMajor Version
_tvVersion Int
major' Int
minor'
        )
    ([GHCTargetVersion] -> m (Maybe GHCTargetVersion))
-> [GHCTargetVersion] -> m (Maybe GHCTargetVersion)
forall a b. (a -> b) -> a -> b
$ [GHCTargetVersion]
ghcs


-- | Get the latest available ghc for X.Y major version.
getLatestGHCFor :: Int -- ^ major version component
                -> Int -- ^ minor version component
                -> GHCupDownloads
                -> Maybe (Version, VersionInfo)
getLatestGHCFor :: Int -> Int -> GHCupDownloads -> Maybe (Version, VersionInfo)
getLatestGHCFor Int
major' Int
minor' GHCupDownloads
dls =
  Optic' An_AffineFold '[] GHCupDownloads [(Version, VersionInfo)]
-> GHCupDownloads -> Maybe [(Version, VersionInfo)]
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
     (IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
GHC Optic
  An_AffineTraversal
  '[]
  GHCupDownloads
  GHCupDownloads
  (Map Version VersionInfo)
  (Map Version VersionInfo)
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
-> Optic' An_AffineFold '[] GHCupDownloads [(Version, VersionInfo)]
forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map Version VersionInfo -> [(Version, VersionInfo)])
-> Optic
     A_Getter
     '[]
     (Map Version VersionInfo)
     (Map Version VersionInfo)
     [(Version, VersionInfo)]
     [(Version, VersionInfo)]
forall s a. (s -> a) -> Getter s a
to Map Version VersionInfo -> [(Version, VersionInfo)]
forall k a. Map k a -> [(k, a)]
Map.toDescList) GHCupDownloads
dls Maybe [(Version, VersionInfo)]
-> ([(Version, VersionInfo)] -> Maybe (Version, VersionInfo))
-> Maybe (Version, VersionInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Version, VersionInfo)] -> Maybe (Version, VersionInfo)
forall a. [a] -> Maybe a
lastMay ([(Version, VersionInfo)] -> Maybe (Version, VersionInfo))
-> ([(Version, VersionInfo)] -> [(Version, VersionInfo)])
-> [(Version, VersionInfo)]
-> Maybe (Version, VersionInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, VersionInfo) -> Bool)
-> [(Version, VersionInfo)] -> [(Version, VersionInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Version
v, VersionInfo
_) -> Version -> Int -> Int -> Bool
matchMajor Version
v Int
major' Int
minor')




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



-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
            => Path Abs       -- ^ destination dir
            -> Path Abs       -- ^ archive path
            -> Excepts '[UnknownArchive
#if !defined(TAR)
                        , ArchiveResult
#endif
                        ] m ()
unpackToDir :: Path Abs
-> Path Abs -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir Path Abs
dest Path Abs
av = do
  Text
fp <- ByteString -> Text
decUTF8Safe (ByteString -> Text)
-> (Path Rel -> ByteString) -> Path Rel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> Text)
-> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
-> Excepts '[UnknownArchive, ArchiveResult] m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs -> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
forall (m :: * -> *) b. MonadThrow m => Path b -> m (Path Rel)
basename Path Abs
av
  let dfp :: Text
dfp = ByteString -> Text
decUTF8Safe (ByteString -> Text)
-> (Path Abs -> ByteString) -> Path Abs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Abs -> Text) -> Path Abs -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs
dest
  m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[UnknownArchive, ArchiveResult] m ())
-> m () -> Excepts '[UnknownArchive, ArchiveResult] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) [i|Unpacking: #{fp} to #{dfp}|]
  ByteString
fn <- Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> ByteString)
-> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs -> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
forall (m :: * -> *) b. MonadThrow m => Path b -> m (Path Rel)
basename Path Abs
av

#if defined(TAR)
  let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
      untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read

      rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
      rf = liftIO . readFile
#else
  let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
      untar :: ByteString -> Excepts '[ArchiveResult] m ()
untar = m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM (m (Either ArchiveResult ()) -> Excepts '[ArchiveResult] m ())
-> (ByteString -> m (Either ArchiveResult ()))
-> ByteString
-> Excepts '[ArchiveResult] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ArchiveResult ()) -> m (Either ArchiveResult ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ArchiveResult ()) -> m (Either ArchiveResult ()))
-> (ByteString -> IO (Either ArchiveResult ()))
-> ByteString
-> m (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM () -> IO (Either ArchiveResult ())
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM (ArchiveM () -> IO (Either ArchiveResult ()))
-> (ByteString -> ArchiveM ())
-> ByteString
-> IO (Either ArchiveResult ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString -> ArchiveM ()
unpackToDirLazy (Text -> String
T.unpack (Text -> String) -> (Path Abs -> Text) -> Path Abs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe (ByteString -> Text)
-> (Path Abs -> ByteString) -> Path Abs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Abs -> String) -> Path Abs -> String
forall a b. (a -> b) -> a -> b
$ Path Abs
dest)

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

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


getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
                => Path Abs       -- ^ archive path
                -> Excepts '[UnknownArchive
#if defined(TAR)
                            , Tar.FormatError
#else
                            , ArchiveResult
#endif
                            ] m [ByteString]
getArchiveFiles :: Path Abs -> Excepts '[UnknownArchive, ArchiveResult] m [ByteString]
getArchiveFiles Path Abs
av = do
  ByteString
fn <- Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> ByteString)
-> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
-> Excepts '[UnknownArchive, ArchiveResult] m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs -> Excepts '[UnknownArchive, ArchiveResult] m (Path Rel)
forall (m :: * -> *) b. MonadThrow m => Path b -> m (Path Rel)
basename Path Abs
av

#if defined(TAR)
  let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
      entries =
          lE @Tar.FormatError
          . Tar.foldEntries
            (\e x -> fmap (Tar.entryPath e :) x)
            (Right [])
            (\e -> Left e)
          . Tar.read

      rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
      rf = liftIO . readFile
#else
  let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
      entries :: ByteString -> Excepts '[ArchiveResult] m [ByteString]
entries = (([Entry String ByteString] -> [ByteString])
-> Excepts '[ArchiveResult] m [Entry String ByteString]
-> Excepts '[ArchiveResult] m [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Entry String ByteString] -> [ByteString])
 -> Excepts '[ArchiveResult] m [Entry String ByteString]
 -> Excepts '[ArchiveResult] m [ByteString])
-> ((Entry String ByteString -> ByteString)
    -> [Entry String ByteString] -> [ByteString])
-> (Entry String ByteString -> ByteString)
-> Excepts '[ArchiveResult] m [Entry String ByteString]
-> Excepts '[ArchiveResult] m [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry String ByteString -> ByteString)
-> [Entry String ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Text -> ByteString
E.encodeUtf8 (Text -> ByteString)
-> (Entry String ByteString -> Text)
-> Entry String ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (Entry String ByteString -> String)
-> Entry String ByteString
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry String ByteString -> String
forall fp e. Entry fp e -> fp
filepath) (Excepts '[ArchiveResult] m [Entry String ByteString]
 -> Excepts '[ArchiveResult] m [ByteString])
-> (ByteString
    -> Excepts '[ArchiveResult] m [Entry String ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ArchiveResult [Entry String ByteString]
-> Excepts '[ArchiveResult] m [Entry String ByteString]
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE (Either ArchiveResult [Entry String ByteString]
 -> Excepts '[ArchiveResult] m [Entry String ByteString])
-> (ByteString -> Either ArchiveResult [Entry String ByteString])
-> ByteString
-> Excepts '[ArchiveResult] m [Entry String ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ArchiveResult [Entry String ByteString]
readArchiveBSL

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

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


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




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


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

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

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


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



    -----------------------
    --[ AppState Getter ]--
    -----------------------


getCache :: MonadReader AppState m => m Bool
getCache :: m Bool
getCache = m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask m AppState -> (AppState -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Settings -> Bool
cache (Settings -> Bool) -> (AppState -> Settings) -> AppState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Settings
settings


getDownloader :: MonadReader AppState m => m Downloader
getDownloader :: m Downloader
getDownloader = m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask m AppState -> (AppState -> Downloader) -> m Downloader
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Settings -> Downloader
downloader (Settings -> Downloader)
-> (AppState -> Settings) -> AppState -> Downloader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Settings
settings



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


urlBaseName :: MonadThrow m
            => ByteString  -- ^ the url path (without scheme and host)
            -> m (Path Rel)
urlBaseName :: ByteString -> m (Path Rel)
urlBaseName = ByteString -> m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel (ByteString -> m (Path Rel))
-> (ByteString -> ByteString) -> ByteString -> m (Path Rel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.breakEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_slash) (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlDecode Bool
False


-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
--
-- Returns unversioned relative files, e.g.:
--
--   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
             => GHCTargetVersion
             -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles :: GHCTargetVersion -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles GHCTargetVersion
ver = do
  Path Abs
ghcdir <- m (Path Abs) -> Excepts '[NotInstalled] m (Path Abs)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Path Abs) -> Excepts '[NotInstalled] m (Path Abs))
-> m (Path Abs) -> Excepts '[NotInstalled] m (Path Abs)
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> m (Path Abs)
forall (m :: * -> *).
(MonadReader AppState m, MonadThrow m) =>
GHCTargetVersion -> m (Path Abs)
ghcupGHCDir GHCTargetVersion
ver
  let bindir :: Path Abs
bindir = Path Abs
ghcdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|bin|]

  -- fail if ghc is not installed
  Excepts '[NotInstalled] m Bool
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool)
-> Excepts '[NotInstalled] m Bool -> Excepts '[NotInstalled] m Bool
forall a b. (a -> b) -> a -> b
$ IO Bool -> Excepts '[NotInstalled] m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[NotInstalled] m Bool)
-> IO Bool -> Excepts '[NotInstalled] m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
forall b. Path b -> IO Bool
doesDirectoryExist Path Abs
ghcdir)
        (NotInstalled -> Excepts '[NotInstalled] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))

  [Path Rel]
files    <- IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel])
-> IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO [Path Rel]
forall b. Path b -> IO [Path Rel]
getDirsFiles' Path Abs
bindir
  -- figure out the <ver> suffix, because this might not be `Version` for
  -- alpha/rc releases, but x.y.a.somedate.

  -- for cross, this won't be "ghc", but e.g.
  -- "armv7-unknown-linux-gnueabihf-ghc"
  [Path Rel
ghcbin] <- IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel])
-> IO [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ Path Abs -> Regex -> IO [Path Rel]
findFiles
    Path Abs
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|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
    )

  let ghcbinPath :: Path Abs
ghcbinPath = Path Abs
bindir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
ghcbin
  Bool
ghcIsHadrian    <- IO Bool -> Excepts '[NotInstalled] m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[NotInstalled] m Bool)
-> IO Bool -> Excepts '[NotInstalled] m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
isHadrian Path Abs
ghcbinPath
  [Path Rel] -> [Path Rel]
onlyUnversioned <- if Bool
ghcIsHadrian
    then ([Path Rel] -> [Path Rel])
-> Excepts '[NotInstalled] m ([Path Rel] -> [Path Rel])
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Path Rel] -> [Path Rel]
forall a. a -> a
id
    else do
      (Just ByteString
symver) <-
        ByteString -> ByteString -> Maybe ByteString
B.stripPrefix (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
ghcbin ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"-") (ByteString -> Maybe ByteString)
-> (ByteString -> ByteString) -> ByteString -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
takeFileName
          (ByteString -> Maybe ByteString)
-> Excepts '[NotInstalled] m ByteString
-> Excepts '[NotInstalled] m (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> Excepts '[NotInstalled] m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> IO ByteString
readSymbolicLink (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
ghcbinPath)
      Bool
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
symver)
           (IOException -> Excepts '[NotInstalled] m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> Excepts '[NotInstalled] m ())
-> IOException -> Excepts '[NotInstalled] m ()
forall a b. (a -> b) -> a -> b
$ String -> IOException
userError String
"Fatal: ghc symlink target is broken")
      ([Path Rel] -> [Path Rel])
-> Excepts '[NotInstalled] m ([Path Rel] -> [Path Rel])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Path Rel] -> [Path Rel])
 -> Excepts '[NotInstalled] m ([Path Rel] -> [Path Rel]))
-> ([Path Rel] -> [Path Rel])
-> Excepts '[NotInstalled] m ([Path Rel] -> [Path Rel])
forall a b. (a -> b) -> a -> b
$ (Path Rel -> Bool) -> [Path Rel] -> [Path Rel]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Path Rel
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
symver ByteString -> ByteString -> Bool
`B.isSuffixOf` Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
x)

  [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path Rel] -> Excepts '[NotInstalled] m [Path Rel])
-> [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
forall a b. (a -> b) -> a -> b
$ [Path Rel] -> [Path Rel]
onlyUnversioned [Path Rel]
files
 where
    -- GHC is moving some builds to Hadrian for bindists,
    -- which doesn't create versioned binaries.
    -- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
  isHadrian :: Path Abs -- ^ ghcbin path
            -> IO Bool
  isHadrian :: Path Abs -> IO Bool
isHadrian = (FileType -> Bool) -> IO FileType -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileType -> FileType -> Bool
forall a. Eq a => a -> a -> Bool
/= FileType
SymbolicLink) (IO FileType -> IO Bool)
-> (Path Abs -> IO FileType) -> Path Abs -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs -> IO FileType
forall b. Path b -> IO FileType
getFileType


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


-- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
     => [ByteString]
     -> Maybe (Path Abs)
     -> m (Either ProcessError ())
make :: [ByteString] -> Maybe (Path Abs) -> m (Either ProcessError ())
make [ByteString]
args Maybe (Path Abs)
workdir = do
  [Path Abs]
spaths    <- [Maybe (Path Abs)] -> [Path Abs]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Path Abs)] -> [Path Abs])
-> ([ByteString] -> [Maybe (Path Abs)])
-> [ByteString]
-> [Path Abs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Path Abs))
-> [ByteString] -> [Maybe (Path Abs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ([ByteString] -> [Path Abs]) -> m [ByteString] -> m [Path Abs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ByteString] -> m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ByteString]
getSearchPath
  Bool
has_gmake <- Maybe (Path Abs) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Path Abs) -> Bool) -> m (Maybe (Path Abs)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Path Abs)) -> m (Maybe (Path Abs))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
searchPath [Path Abs]
spaths [rel|gmake|])
  let mymake :: ByteString
mymake = if Bool
has_gmake then ByteString
"gmake" else ByteString
"make"
  ByteString
-> Bool
-> [ByteString]
-> Path Rel
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> m (Either ProcessError ())
forall (m :: * -> *).
(MonadReader AppState m, MonadIO m, MonadThrow m) =>
ByteString
-> Bool
-> [ByteString]
-> Path Rel
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> m (Either ProcessError ())
execLogged ByteString
mymake Bool
True [ByteString]
args [rel|ghc-make|] Maybe (Path Abs)
workdir Maybe [(ByteString, ByteString)]
forall a. Maybe a
Nothing


-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadLogger m, MonadIO m)
             => Path Abs   -- ^ dir containing patches
             -> Path Abs   -- ^ dir to apply patches in
             -> Excepts '[PatchFailed] m ()
applyPatches :: Path Abs -> Path Abs -> Excepts '[PatchFailed] m ()
applyPatches Path Abs
pdir Path Abs
ddir = do
  [Path Abs]
patches <- IO [Path Abs] -> Excepts '[PatchFailed] m [Path Abs]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Path Abs] -> Excepts '[PatchFailed] m [Path Abs])
-> IO [Path Abs] -> Excepts '[PatchFailed] m [Path Abs]
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO [Path Abs]
forall b. Path b -> IO [Path b]
getDirsFiles Path Abs
pdir
  [Path Abs]
-> (Path Abs -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Path Abs] -> [Path Abs]
forall a. Ord a => [a] -> [a]
sort [Path Abs]
patches) ((Path Abs -> Excepts '[PatchFailed] m ())
 -> Excepts '[PatchFailed] m ())
-> (Path Abs -> Excepts '[PatchFailed] m ())
-> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ \Path Abs
patch' -> do
    m () -> Excepts '[PatchFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[PatchFailed] m ())
-> m () -> Excepts '[PatchFailed] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) [i|Applying patch #{patch'}|]
    (Either ProcessError () -> Maybe ())
-> m (Either ProcessError ()) -> m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProcessError -> Maybe ())
-> (() -> Maybe ()) -> Either ProcessError () -> Maybe ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe () -> ProcessError -> Maybe ()
forall a b. a -> b -> a
const Maybe ()
forall a. Maybe a
Nothing) () -> Maybe ()
forall a. a -> Maybe a
Just)
         (IO (Either ProcessError ()) -> m (Either ProcessError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ProcessError ()) -> m (Either ProcessError ()))
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ ByteString
-> Bool
-> [ByteString]
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> IO (Either ProcessError ())
exec
           ByteString
"patch"
           Bool
True
           [ByteString
"-p1", ByteString
"-i", Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
patch']
           (Path Abs -> Maybe (Path Abs)
forall a. a -> Maybe a
Just Path Abs
ddir)
           Maybe [(ByteString, ByteString)]
forall a. Maybe a
Nothing)
      m (Maybe ()) -> PatchFailed -> Excepts '[PatchFailed] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Maybe a) -> e -> Excepts es m a
!? PatchFailed
PatchFailed


-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization Platform
Darwin Path Abs
path = ByteString
-> Bool
-> [ByteString]
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> IO (Either ProcessError ())
exec
  ByteString
"xattr"
  Bool
True
  [ByteString
"-r", ByteString
"-d", ByteString
"com.apple.quarantine", Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
path]
  Maybe (Path Abs)
forall a. Maybe a
Nothing
  Maybe [(ByteString, ByteString)]
forall a. Maybe a
Nothing
darwinNotarization Platform
_ Path Abs
_ = Either ProcessError () -> IO (Either ProcessError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProcessError () -> IO (Either ProcessError ()))
-> Either ProcessError () -> IO (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ProcessError ()
forall a b. b -> Either a b
Right ()


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


-- | Execute a build action while potentially cleaning up:
--
--   1. the build directory, depending on the KeepDirs setting
--   2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
               => Path Abs          -- ^ build directory (cleaned up depending on Settings)
               -> Maybe (Path Abs)  -- ^ dir to *always* clean up on exception
               -> Excepts e m a
               -> Excepts '[BuildFailed] m a
runBuildAction :: Path Abs
-> Maybe (Path Abs) -> Excepts e m a -> Excepts '[BuildFailed] m a
runBuildAction Path Abs
bdir Maybe (Path Abs)
instdir Excepts e m a
action = do
  AppState { settings :: AppState -> Settings
settings = Settings {Bool
Downloader
KeepDirs
URLSource
urlSource :: Settings -> URLSource
verbose :: Settings -> Bool
keepDirs :: Settings -> KeepDirs
noVerify :: Settings -> Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
cache :: Bool
downloader :: Settings -> Downloader
cache :: Settings -> Bool
..} } <- m AppState -> Excepts '[BuildFailed] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  let exAction :: Excepts '[BuildFailed] m ()
exAction = do
        Maybe (Path Abs)
-> (Path Abs -> Excepts '[BuildFailed] m ())
-> Excepts '[BuildFailed] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs)
instdir ((Path Abs -> Excepts '[BuildFailed] m ())
 -> Excepts '[BuildFailed] m ())
-> (Path Abs -> Excepts '[BuildFailed] m ())
-> Excepts '[BuildFailed] m ()
forall a b. (a -> b) -> a -> b
$ \Path Abs
dir ->
          IO () -> Excepts '[BuildFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[BuildFailed] m ())
-> IO () -> Excepts '[BuildFailed] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteDirRecursive Path Abs
dir
        Bool -> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Never)
          (Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m ())
-> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m ()
forall a b. (a -> b) -> a -> b
$ IO () -> Excepts '[BuildFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> Excepts '[BuildFailed] m ())
-> IO () -> Excepts '[BuildFailed] m ()
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
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteDirRecursive Path Abs
bdir
  a
v <-
    (Excepts '[BuildFailed] m a
 -> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m a)
-> Excepts '[BuildFailed] m ()
-> Excepts '[BuildFailed] m a
-> Excepts '[BuildFailed] m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts '[BuildFailed] m a
-> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException Excepts '[BuildFailed] m ()
exAction
    (Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a)
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
forall a b. (a -> b) -> a -> b
$ (V e -> Excepts '[BuildFailed] m a)
-> Excepts e m a -> Excepts '[BuildFailed] m a
forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE
        (\V e
es -> do
          Excepts '[BuildFailed] m ()
exAction
          BuildFailed -> Excepts '[BuildFailed] m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Path Abs -> V e -> BuildFailed
forall (es :: [*]). Show (V es) => Path Abs -> V es -> BuildFailed
BuildFailed Path Abs
bdir V e
es)
        ) Excepts e m a
action

  Bool -> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] 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 '[BuildFailed] m () -> Excepts '[BuildFailed] m ())
-> Excepts '[BuildFailed] m () -> Excepts '[BuildFailed] m ()
forall a b. (a -> b) -> a -> b
$ IO () -> Excepts '[BuildFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[BuildFailed] m ())
-> IO () -> Excepts '[BuildFailed] m ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteDirRecursive
    Path Abs
bdir
  a -> Excepts '[BuildFailed] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v


-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' :: Path b -> IO ()
createDirRecursive' Path b
p =
  (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e then IOException -> IO ()
forall e. Exception e => e -> IO ()
isSymlinkDir IOException
e else IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
    (IO () -> IO ()) -> (Path b -> IO ()) -> Path b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileMode -> Path b -> IO ()
forall b. FileMode -> Path b -> IO ()
createDirRecursive FileMode
newDirPerms
    (Path b -> IO ()) -> Path b -> IO ()
forall a b. (a -> b) -> a -> b
$ Path b
p

 where
  isSymlinkDir :: e -> IO ()
isSymlinkDir e
e = do
    FileType
ft <- Path b -> IO FileType
forall b. Path b -> IO FileType
getFileType Path b
p
    case FileType
ft of
      FileType
SymbolicLink -> do
        Path Abs
rp <- Path b -> IO (Path Abs)
forall b. Path b -> IO (Path Abs)
canonicalizePath Path b
p
        FileType
rft <- Path Abs -> IO FileType
forall b. Path b -> IO FileType
getFileType Path Abs
rp
        case FileType
rft of
          FileType
Directory -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          FileType
_ -> e -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
      FileType
_ -> e -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e


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


-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold :: (a -> m b) -> t a -> m b
traverseFold a -> m b
f = (m b -> a -> m b) -> m b -> t a -> m b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\m b
mb a
a -> b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) (b -> b -> b) -> m b -> m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
mb m (b -> b) -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m b
f a
a) (b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty)

-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold :: t a -> (a -> m b) -> m b
forFold = \t a
t -> ((a -> m b) -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Applicative m, Monoid b) =>
(a -> m b) -> t a -> m b
`traverseFold` t a
t)