{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
#if defined(IS_WINDOWS)
, module GHCup.Prelude.Windows
#else
, module GHCup.Prelude.Posix
#endif
)
where
#if defined(IS_WINDOWS)
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.Posix
#endif
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Version
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal
import GHCup.Prelude.MegaParsec
import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ
import Codec.Archive hiding ( Directory )
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit )
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.Maybe
import Data.Text ( Text )
import Data.Versions hiding ( patch )
import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Safe
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import Text.PrettyPrint.HughesPJClass (prettyShow)
import URI.ByteString
import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import qualified Data.List.NonEmpty as NE
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)
import System.Environment (getEnvironment, setEnv)
import Data.Time (Day(..), diffDays, addDays)
binarySymLinkDestination :: ( MonadThrow m
, MonadIO m
)
=> FilePath
-> FilePath
-> m FilePath
binarySymLinkDestination :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binarySymLinkDestination [Char]
binDir [Char]
toolPath = do
[Char]
toolPath' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
toolPath
[Char]
binDir' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
binDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char] -> [Char]
relativeSymlink [Char]
binDir' [Char]
toolPath')
rmMinorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMinorGHCSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
_tvVersion :: Version
_tvTarget :: Maybe Text
..} = do
Dirs {[Char]
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
files <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
let f_xyz :: [Char]
f_xyz = [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
_tvVersion) forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f_xyz
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
fullF
rmPlainGHC :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
rmPlainGHC :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Maybe Text -> Excepts '[NotInstalled] m ()
rmPlainGHC Maybe Text
target = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
Maybe GHCTargetVersion
mtv <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
target
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GHCTargetVersion
mtv forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion
tv -> do
[[Char]]
files <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
fullF
let hdc_file :: [Char]
hdc_file = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haddock-ghc" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
hdc_file)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
hdc_file
rmMajorGHCSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m ()
rmMajorGHCSymlinks tv :: GHCTargetVersion
tv@GHCTargetVersion{Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
..} = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
(Int
mj, Int
mi) <- forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
_tvVersion
let v' :: Text
v' = forall a. Integral a => a -> Text
intToText Int
mj forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Text
intToText Int
mi
[[Char]]
files <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
tv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
let f_xy :: [Char]
f_xy = [Char]
f forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
v' forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f_xy
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
fullF
rmMinorHLSSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> Version
-> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, HasLog env,
MonadThrow m, MonadFail m, MonadMask m) =>
Version -> Excepts '[NotInstalled] m ()
rmMinorHLSSymlinks Version
ver = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
hlsBins <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> m [[Char]]
hlsAllBinaries Version
ver
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
hlsBins forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => [Char] -> m ()
rmFile [Char]
fullF
rmPlainHLS :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Excepts '[NotInstalled] m ()
rmPlainHLS :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadFail m, MonadIO m, MonadMask m) =>
Excepts '[NotInstalled] m ()
rmPlainHLS = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
hlsBins <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> Bool -> Bool
not ([Char]
"haskell-language-server-wrapper" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
f) Bool -> Bool -> Bool
&& (Char
'~' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
f)))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
hlsBins forall a b. (a -> b) -> a -> b
$ \[Char]
f -> do
let fullF :: [Char]
fullF = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
f
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fullF)
if Bool
isWindows
then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
fullF
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => [Char] -> m ()
rmFile [Char]
fullF
let hlswrapper :: [Char]
hlswrapper = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
hlswrapper)
if Bool
isWindows
then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
[Char] -> m ()
rmLink [Char]
hlswrapper
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => [Char] -> m ()
rmFile [Char]
hlswrapper
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver = do
GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesDirectoryExist (GHCupPath -> [Char]
fromGHCupPath GHCupPath
ghcdir)
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcSrcInstalled GHCTargetVersion
ver = do
GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist (GHCupPath -> [Char]
fromGHCupPath GHCupPath
ghcdir [Char] -> [Char] -> [Char]
</> [Char]
ghcUpSrcBuiltFile)
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Maybe Text
-> m (Maybe GHCTargetVersion)
ghcSet :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet Maybe Text
mtarget = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let ghc :: [Char]
ghc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"ghc" (\Text
t -> Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"-ghc") Maybe Text
mtarget
let ghcBin :: [Char]
ghcBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
ghc forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
[Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
ghcBin
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
ghcLinkVersion [Char]
link
where
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
ghcLinkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
ghcLinkVersion ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt -> Text
t) = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity GHCTargetVersion
parser [Char]
"ghcLinkVersion" Text
t
where
parser :: ParsecT Void Text Identity GHCTargetVersion
parser =
(do
Text
_ <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 ParsecT Void Text Identity [Char]
ghcSubPath
[Char]
_ <- ParsecT Void Text Identity [Char]
ghcSubPath
Text
r <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep
Text
rest <- forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
r
GHCTargetVersion
x <- ParsecT Void Text Identity GHCTargetVersion
ghcTargetVerP
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCTargetVersion
x
)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
MP.takeRest
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof
ghcSubPath :: ParsecT Void Text Identity [Char]
ghcSubPath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"ghc" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
m [Either [Char] GHCTargetVersion]
getInstalledGHCs = do
GHCupPath
ghcdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupGHCBaseDir
[[Char]]
fs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectoryDirs (GHCupPath -> [Char]
fromGHCupPath GHCupPath
ghcdir)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fs forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case forall (m :: * -> *). MonadThrow m => [Char] -> m GHCTargetVersion
parseGHCupGHCDir [Char]
f of
Right GHCTargetVersion
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right GHCTargetVersion
r
Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
)
=> m [Either FilePath Version]
getInstalledCabals :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledCabals = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
bins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^cabal-.*$|] :: ByteString))
[Either [Char] Version]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"cabal-" [Char]
f) of
Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
Just (Left ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Either [Char] Version]
vs
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
cabalInstalled Version
ver = do
[Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledCabals
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: forall env (m :: * -> *).
(HasLog env, MonadReader env m, HasDirs env, MonadIO m,
MonadThrow m, MonadCatch m) =>
m (Maybe Version)
cabalSet = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let cabalbin :: [Char]
cabalbin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"cabal" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
Bool
broken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
isBrokenSymlink [Char]
cabalbin
if Bool
broken
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else do
Either SomeException [Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InvalidArgument
(\IOException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall e. Exception e => e -> SomeException
toException IOException
e))
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
cabalbin
case forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either SomeException [Char]
link of
Right Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Version
v
Left SomeException
err -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse cabal symlink target with: "
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall e. Exception e => e -> [Char]
displayException SomeException
err)
forall a. Semigroup a => a -> a -> a
<> Text
". The symlink "
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
cabalbin
forall a. Semigroup a => a -> a -> a
<> Text
" needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
where
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity Version
parser [Char]
"linkVersion" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt
parser :: ParsecT Void Text Identity Version
parser
= forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Version
cabalParse
cabalParse :: ParsecT Void Text Identity Version
cabalParse = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"cabal-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
version'
stripPathComponet :: ParsecT Void Text Identity [Char]
stripPathComponet = forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
stripAbsolutePath :: ParsecT Void Text Identity [[Char]]
stripAbsolutePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
stripRelativePath :: ParsecT Void Text Identity [[Char]]
stripRelativePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledHLSs :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledHLSs = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
bins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
[Either [Char] Version]
legacy <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f ->
case
Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"haskell-language-server-wrapper-" [Char]
f)
of
Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
Just (Left ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
GHCupPath
hlsdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupHLSBaseDir
[[Char]]
fs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectoryDirs (GHCupPath -> [Char]
fromGHCupPath GHCupPath
hlsdir)
[Either [Char] Version]
new <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
fs forall a b. (a -> b) -> a -> b
$ \[Char]
f -> case forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseGHCupHLSDir [Char]
f of
Right Version
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Eq a => [a] -> [a]
nub ([Either [Char] Version]
new forall a. Semigroup a => a -> a -> a
<> [Either [Char] Version]
legacy))
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledStacks :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledStacks = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
bins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|^stack-.*$|] :: ByteString)
)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
bins forall a b. (a -> b) -> a -> b
$ \[Char]
f ->
case Text -> Either (ParseErrorBundle Text Void) Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
exeExt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"stack-" [Char]
f) of
Just (Right Version
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Version
r
Just (Left ParseErrorBundle Text Void
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
Maybe (Either (ParseErrorBundle Text Void) Version)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
f
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m, HasLog env) =>
m (Maybe Version)
stackSet = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let stackBin :: [Char]
stackBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"stack" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
Bool
broken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
isBrokenSymlink [Char]
stackBin
if Bool
broken
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else do
Either SomeException [Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InvalidArgument
(\IOException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall e. Exception e => e -> SomeException
toException IOException
e))
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
stackBin
case forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either SomeException [Char]
link of
Right Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Version
v
Left SomeException
err -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse stack symlink target with: "
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall e. Exception e => e -> [Char]
displayException SomeException
err)
forall a. Semigroup a => a -> a -> a
<> Text
". The symlink "
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
stackBin
forall a. Semigroup a => a -> a -> a
<> Text
" needs to point to valid stack binary, such as 'stack-2.7.1'."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
where
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity Version
parser [Char]
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt
where
parser :: ParsecT Void Text Identity Version
parser
= forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Version
cabalParse
cabalParse :: ParsecT Void Text Identity Version
cabalParse = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"stack-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
version'
stripPathComponet :: ParsecT Void Text Identity [Char]
stripPathComponet = forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
stripAbsolutePath :: ParsecT Void Text Identity [[Char]]
stripAbsolutePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
stripRelativePath :: ParsecT Void Text Identity [[Char]]
stripRelativePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
stackInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
stackInstalled Version
ver = do
[Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledStacks
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
hlsInstalled :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
hlsInstalled Version
ver = do
[Version]
vers <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> [b]
rights forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) =>
m [Either [Char] Version]
getInstalledHLSs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Version
ver [Version]
vers
isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
isLegacyHLS :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) =>
Version -> m Bool
isLegacyHLS Version
ver = do
GHCupPath
bdir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ GHCupPath -> [Char]
fromGHCupPath GHCupPath
bdir)
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m (Maybe Version)
hlsSet = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let hlsBin :: [Char]
hlsBin = [Char]
binDir [Char] -> [Char] -> [Char]
</> [Char]
"haskell-language-server-wrapper" forall a. Semigroup a => a -> a -> a
<> [Char]
exeExt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
Bool
broken <- [Char] -> IO Bool
isBrokenSymlink [Char]
hlsBin
if Bool
broken
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else do
[Char]
link <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getLinkTarget [Char]
hlsBin
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion [Char]
link
where
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
linkVersion = forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
MP.parse ParsecT Void Text Identity Version
parser [Char]
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt
where
parser :: ParsecT Void Text Identity Version
parser
= forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripAbsolutePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity [[Char]]
stripRelativePath forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
cabalParse)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Version
cabalParse
cabalParse :: ParsecT Void Text Identity Version
cabalParse = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"haskell-language-server-wrapper-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Version
version'
stripPathComponet :: ParsecT Void Text Identity [Char]
stripPathComponet = forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep
stripAbsolutePath :: ParsecT Void Text Identity [[Char]]
stripAbsolutePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.some Parsec Void Text Char
pathSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
stripRelativePath :: ParsecT Void Text Identity [[Char]]
stripRelativePath = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try ParsecT Void Text Identity [Char]
stripPathComponet)
hlsGHCVersions :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m [Version]
hlsGHCVersions = do
Maybe Version
h <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m (Maybe Version)
hlsSet
forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Version
h forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
Version -> m [Version]
hlsGHCVersions'
hlsGHCVersions' :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> Version
-> m [Version]
hlsGHCVersions' :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
Version -> m [Version]
hlsGHCVersions' Version
v' = do
[[Char]]
bins <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
v' forall a. Maybe a
Nothing
let vers :: [Either (ParseErrorBundle Text Void) Version]
vers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(Text -> Either (ParseErrorBundle Text Void) Version
version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"haskell-language-server-"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"~"
)
[[Char]]
bins
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ [Either (ParseErrorBundle Text Void) Version]
vers
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version
-> Maybe Version
-> m [FilePath]
hlsServerBinaries :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
ver Maybe Version
mghcVer = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
CompOption
compExtended
ExecOption
execBlank
([s|^haskell-language-server-|]
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [s|.*|] Version -> ByteString
escapeVerRex Maybe Version
mghcVer
forall a. Semigroup a => a -> a -> a
<> [s|~|]
forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 ([Char] -> Text
T.pack [Char]
exeExt)
forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
)
)
hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
=> Version
-> Maybe Version
-> m [FilePath]
hlsInternalServerScripts :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> Maybe Version -> m [[Char]]
hlsInternalServerScripts Version
ver Maybe Version
mghcVer = do
GHCupPath
dir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
let bdir :: [Char]
bdir = GHCupPath -> [Char]
fromGHCupPath GHCupPath
dir [Char] -> [Char] -> [Char]
</> [Char]
"bin"
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
bdir)
hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
=> Version
-> Maybe Version
-> m [FilePath]
hlsInternalServerBinaries :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadFail m) =>
Version -> Maybe Version -> m [[Char]]
hlsInternalServerBinaries Version
ver Maybe Version
mghcVer = do
[Char]
dir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
let regex :: Regex
regex = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just [Char]
bdir) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), forall a b. b -> Either a b
Right Regex
regex, forall a b. a -> Either a b
Left [Char]
"bin"]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\[Char]
f -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Version
gv -> ([Char]
"-" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
gv)) forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f) Maybe Version
mghcVer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
bdir)
hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
=> Version
-> Version
-> m [FilePath]
hlsInternalServerLibs :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadFail m) =>
Version -> Version -> m [[Char]]
hlsInternalServerLibs Version
ver Version
ghcVer = do
[Char]
dir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver
let regex :: Regex
regex = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended ExecOption
execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(Just [Char]
bdir) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Either [Char] Regex] -> IO [[Char]]
expandFilePath [forall a b. a -> Either a b
Left ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"lib"), forall a b. b -> Either a b
Right Regex
regex, forall a b. a -> Either a b
Left ([Char]
"lib" [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack (Version -> Text
prettyVer Version
ghcVer))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
bdir [Char] -> [Char] -> [Char]
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
bdir)
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe FilePath)
hlsWrapperBinary :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe [Char])
hlsWrapperBinary Version
ver = do
Dirs {[Char]
GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: [Char]
baseDir :: GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> [Char]
$sel:baseDir:Dirs :: Dirs -> GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
[[Char]]
wrapper <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
binDir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
CompOption
compExtended
ExecOption
execBlank
([s|^haskell-language-server-wrapper-|] forall a. Semigroup a => a -> a -> a
<> Version -> ByteString
escapeVerRex Version
ver forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 ([Char] -> Text
T.pack [Char]
exeExt) forall a. Semigroup a => a -> a -> a
<> [s|$|] :: ByteString
)
)
case [[Char]]
wrapper of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[[Char]
x] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
x
[[Char]]
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> UnexpectedListLength
UnexpectedListLength
[Char]
"There were multiple hls wrapper binaries for a single version"
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
Version -> m [[Char]]
hlsAllBinaries Version
ver = do
[[Char]]
hls <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Version -> Maybe Version -> m [[Char]]
hlsServerBinaries Version
ver forall a. Maybe a
Nothing
Maybe [Char]
wrapper <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Version -> m (Maybe [Char])
hlsWrapperBinary Version
ver
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a -> [a]
maybeToList Maybe [Char]
wrapper forall a. [a] -> [a] -> [a]
++ [[Char]]
hls)
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV :: forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {[VChunk]
Maybe Word
Maybe Text
NonEmpty VChunk
_vEpoch :: Version -> Maybe Word
_vChunks :: Version -> NonEmpty VChunk
_vRel :: Version -> [VChunk]
_vMeta :: Version -> Maybe Text
_vMeta :: Maybe Text
_vRel :: [VChunk]
_vChunks :: NonEmpty VChunk
_vEpoch :: Maybe Word
..} = case NonEmpty VChunk
_vChunks of
((Digits Word
x :| []) :| ((Digits Word
y :| []):[VChunk]
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
y)
NonEmpty VChunk
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> ParseError
ParseError [Char]
"Could not parse X.Y from version"
matchMajor :: Version -> Int -> Int -> Bool
matchMajor :: Version -> Int -> Int -> Bool
matchMajor Version
v' Int
major' Int
minor' = case forall (m :: * -> *). MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version
v' of
Just (Int
x, Int
y) -> Int
x forall a. Eq a => a -> a -> Bool
== Int
major' Bool -> Bool -> Bool
&& Int
y forall a. Eq a => a -> a -> Bool
== Int
minor'
Maybe (Int, Int)
Nothing -> Bool
False
matchPVPrefix :: PVP -> PVP -> Bool
matchPVPrefix :: PVP -> PVP -> Bool
matchPVPrefix (PVP -> [Int]
toL -> [Int]
prefix) (PVP -> [Int]
toL -> [Int]
full) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [Int]
prefix [Int]
full
toL :: PVP -> [Int]
toL :: PVP -> [Int]
toL (PVP NonEmpty Word
inner) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty Word
inner
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
=> PVP
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) =>
PVP -> Maybe Text -> m (Maybe GHCTargetVersion)
getGHCForPVP PVP
pvpIn Maybe Text
mt = do
[GHCTargetVersion]
ghcs <- forall a b. [Either a b] -> [b]
rights forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
m [Either [Char] GHCTargetVersion]
getInstalledGHCs
let ghcs' :: [(PVP, Text, Maybe Text)]
ghcs' = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GHCTargetVersion]
ghcs forall a b. (a -> b) -> a -> b
$ \GHCTargetVersion{Maybe Text
Version
_tvVersion :: Version
_tvTarget :: Maybe Text
$sel:_tvVersion:GHCTargetVersion :: GHCTargetVersion -> Version
$sel:_tvTarget:GHCTargetVersion :: GHCTargetVersion -> Maybe Text
..} -> do
(PVP
pvp_, Text
rest) <- forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP Version
_tvVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP
pvp_, Text
rest, Maybe Text
_tvTarget)
forall (m :: * -> *).
MonadThrow m =>
PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP' PVP
pvpIn [(PVP, Text, Maybe Text)]
ghcs' Maybe Text
mt
getGHCForPVP' :: MonadThrow m
=> PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP' :: forall (m :: * -> *).
MonadThrow m =>
PVP
-> [(PVP, Text, Maybe Text)]
-> Maybe Text
-> m (Maybe GHCTargetVersion)
getGHCForPVP' PVP
pvpIn [(PVP, Text, Maybe Text)]
ghcs' Maybe Text
mt = do
let mResult :: Maybe (PVP, Text, Maybe Text)
mResult = forall a. [a] -> Maybe a
lastMay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(PVP
x, Text
_, Maybe Text
_) (PVP
y, Text
_, Maybe Text
_) -> forall a. Ord a => a -> a -> Ordering
compare PVP
x PVP
y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter
(\(PVP
pvp_, Text
_, Maybe Text
target) ->
Maybe Text
target forall a. Eq a => a -> a -> Bool
== Maybe Text
mt Bool -> Bool -> Bool
&& PVP -> PVP -> Bool
matchPVPrefix PVP
pvp_ PVP
pvpIn
)
forall a b. (a -> b) -> a -> b
$ [(PVP, Text, Maybe Text)]
ghcs'
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (PVP, Text, Maybe Text)
mResult forall a b. (a -> b) -> a -> b
$ \(PVP
pvp_, Text
rest, Maybe Text
target) -> do
Version
ver' <- forall (m :: * -> *). MonadThrow m => PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
target Version
ver')
getLatestToolFor :: MonadThrow m
=> Tool
-> Maybe Text
-> PVP
-> GHCupDownloads
-> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor :: forall (m :: * -> *).
MonadThrow m =>
Tool
-> Maybe Text
-> PVP
-> GHCupDownloads
-> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor Tool
tool Maybe Text
target PVP
pvpIn GHCupDownloads
dls = do
let ls :: [(GHCTargetVersion, VersionInfo)]
ls :: [(GHCTargetVersion, VersionInfo)]
ls = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. (s -> a) -> Getter s a
to forall k a. Map k a -> [(k, a)]
Map.toDescList) GHCupDownloads
dls
let ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(GHCTargetVersion
v, VersionInfo
vi) -> (,VersionInfo
vi, GHCTargetVersion -> Maybe Text
_tvTarget GHCTargetVersion
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Version -> m (PVP, Text)
versionToPVP (GHCTargetVersion -> Version
_tvVersion GHCTargetVersion
v)) [(GHCTargetVersion, VersionInfo)]
ls
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((PVP
pv', Text
_), VersionInfo
vi, Maybe Text
mt) -> (PVP
pv', VersionInfo
vi, Maybe Text
mt)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\((PVP
v, Text
_), VersionInfo
_, Maybe Text
t) -> PVP -> PVP -> Bool
matchPVPrefix PVP
pvpIn PVP
v Bool -> Bool -> Bool
&& Maybe Text
t forall a. Eq a => a -> a -> Bool
== Maybe Text
target) forall a b. (a -> b) -> a -> b
$ [((PVP, Text), VersionInfo, Maybe Text)]
ps
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath
-> FilePath
-> Excepts '[UnknownArchive
, ArchiveResult
] m ()
unpackToDir :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
[Char] -> [Char] -> Excepts '[UnknownArchive, ArchiveResult] m ()
unpackToDir [Char]
dfp [Char]
av = do
let fn :: [Char]
fn = [Char] -> [Char]
takeFileName [Char]
av
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Unpacking: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
fn forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
dfp
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar = forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString -> ArchiveM ()
unpackToDirLazy [Char]
dfp
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf :: forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
BL.readFile
if
| [Char]
".tar.gz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
(forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".tar.xz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> do
ByteString
filecontents <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av
let decompressed :: ByteString
decompressed = DecompressParams -> ByteString -> ByteString
Lzma.decompressWith (DecompressParams
Lzma.defaultDecompressParams { decompressAutoDecoder :: Bool
Lzma.decompressAutoDecoder= Bool
True }) ByteString
filecontents
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar ByteString
decompressed
| [Char]
".tar.bz2" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn ->
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".tar" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".zip" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
MonadIO m =>
ByteString -> Excepts '[ArchiveResult] m ()
untar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| Bool
otherwise -> forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ [Char] -> UnknownArchive
UnknownArchive [Char]
fn
getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath
-> Excepts '[UnknownArchive
, ArchiveResult
] m [FilePath]
getArchiveFiles :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
[Char] -> Excepts '[UnknownArchive, ArchiveResult] m [[Char]]
getArchiveFiles [Char]
av = do
let fn :: [Char]
fn = [Char] -> [Char]
takeFileName [Char]
av
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries :: forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall fp e. Entry fp e -> fp
filepath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ArchiveResult [Entry [Char] ByteString]
readArchiveBSL
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf :: forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
BL.readFile
if
| [Char]
".tar.gz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
(forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".tar.xz" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> do
ByteString
filecontents <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av
let decompressed :: ByteString
decompressed = DecompressParams -> ByteString -> ByteString
Lzma.decompressWith (DecompressParams
Lzma.defaultDecompressParams { decompressAutoDecoder :: Bool
Lzma.decompressAutoDecoder= Bool
True }) ByteString
filecontents
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries ByteString
decompressed
| [Char]
".tar.bz2" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn ->
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BZip.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".tar" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| [Char]
".zip" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fn -> forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (forall (m :: * -> *).
Monad m =>
ByteString -> Excepts '[ArchiveResult] m [[Char]]
entries forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
[Char] -> Excepts '[ArchiveResult] m ByteString
rf [Char]
av)
| Bool
otherwise -> forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ [Char] -> UnknownArchive
UnknownArchive [Char]
fn
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> GHCupPath
-> TarDir
-> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m,
MonadCatch m) =>
GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir GHCupPath
bdir TarDir
tardir = case TarDir
tardir of
RealDir [Char]
pr -> do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ GHCupPath -> [Char]
fromGHCupPath (GHCupPath
bdir GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
pr))
(forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
bdir GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
pr)
RegexDir [Char]
r -> do
let rs :: [[Char]]
rs = forall a. (a -> Bool) -> [a] -> [[a]]
split (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
pathSeparators) [Char]
r
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
(\GHCupPath
y [Char]
x ->
(forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex -> IO [[Char]]
findFiles (GHCupPath -> [Char]
fromGHCupPath GHCupPath
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Regex
regex forall a b. (a -> b) -> a -> b
$ [Char]
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case
[] -> forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ TarDir -> TarDirDoesNotExist
TarDirDoesNotExist TarDir
tardir
([Char]
p : [[Char]]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
y GHCupPath -> [Char] -> GHCupPath
`appendGHCupPath` [Char]
p)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
)
GHCupPath
bdir
[[Char]]
rs
where regex :: [Char] -> Regex
regex = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compIgnoreCase ExecOption
execBlank
getTagged :: Tag
-> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged :: Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
tag =
forall s a. (s -> a) -> Getter s a
to (forall k a. Map k a -> [(k, a)]
Map.toDescList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
..} -> Tag
tag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tag]
_viTags))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding forall a. a -> a
id
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay :: GHCupDownloads
-> Tool
-> Day
-> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay GHCupDownloads
av Tool
tool Day
day = let mvv :: Map GHCTargetVersion VersionInfo
mvv = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool) GHCupDownloads
av
mdv :: Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\GHCTargetVersion
k vi :: VersionInfo
vi@VersionInfo{[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
..} Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m ->
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m (\Day
d -> let diff :: Integer
diff = Day -> Day -> Integer
diffDays Day
d Day
day
in forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall a. Num a => a -> a
abs Integer
diff) (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)) Map Integer (Integer, (GHCTargetVersion, VersionInfo))
m) Maybe Day
_viReleaseDay)
forall k a. Map k a
Map.empty Map GHCTargetVersion VersionInfo
mvv
in case forall a. [a] -> Maybe a
headMay (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Integer (Integer, (GHCTargetVersion, VersionInfo))
mdv) of
Maybe (Integer, (Integer, (GHCTargetVersion, VersionInfo)))
Nothing -> forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
Just (Integer
absDiff, (Integer
diff, (GHCTargetVersion
k, VersionInfo
vi)))
| Integer
absDiff forall a. Eq a => a -> a -> Bool
== Integer
0 -> forall a b. b -> Either a b
Right (GHCTargetVersion
k, VersionInfo
vi)
| Bool
otherwise -> forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just (Integer -> Day -> Day
addDays Integer
diff Day
day))
getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold :: Day
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold Day
day = forall s a. (s -> a) -> Getter s a
to (forall k a. Map k a -> [(k, a)]
Map.toDescList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\VersionInfo {[Tag]
Maybe Text
Maybe Day
Maybe URI
Maybe DownloadInfo
ArchitectureSpec
_viPreCompile :: Maybe Text
_viPostRemove :: Maybe Text
_viPostInstall :: Maybe Text
_viArch :: ArchitectureSpec
_viTestDL :: Maybe DownloadInfo
_viSourceDL :: Maybe DownloadInfo
_viChangeLog :: Maybe URI
_viReleaseDay :: Maybe Day
_viTags :: [Tag]
$sel:_viPreCompile:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostRemove:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viPostInstall:VersionInfo :: VersionInfo -> Maybe Text
$sel:_viArch:VersionInfo :: VersionInfo -> ArchitectureSpec
$sel:_viTestDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viSourceDL:VersionInfo :: VersionInfo -> Maybe DownloadInfo
$sel:_viChangeLog:VersionInfo :: VersionInfo -> Maybe URI
$sel:_viReleaseDay:VersionInfo :: VersionInfo -> Maybe Day
$sel:_viTags:VersionInfo :: VersionInfo -> [Tag]
..} -> forall a. a -> Maybe a
Just Day
day forall a. Eq a => a -> a -> Bool
== Maybe Day
_viReleaseDay)) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding forall a. a -> a
id
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
Latest) GHCupDownloads
av
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
LatestPrerelease) GHCupDownloads
av
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
LatestNightly) GHCupDownloads
av
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended GHCupDownloads
av Tool
tool = forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
Recommended) GHCupDownloads
av
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion GHCupDownloads
av PVP
pvpVer =
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
GHC forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged (PVP -> Tag
Base PVP
pvpVer)) GHCupDownloads
av
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> m FilePath
ghcInternalBinDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> m [Char]
ghcInternalBinDir GHCTargetVersion
ver = do
[Char]
ghcdir <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
ghcdir [Char] -> [Char] -> [Char]
</> [Char]
"bin")
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> Excepts '[NotInstalled] m [[Char]]
ghcToolFiles GHCTargetVersion
ver = do
[Char]
bindir <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
MonadIO m) =>
GHCTargetVersion -> m [Char]
ghcInternalBinDir GHCTargetVersion
ver
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m Bool
ghcInstalled GHCTargetVersion
ver)
(forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Tool -> GHCTargetVersion -> NotInstalled
NotInstalled Tool
GHC GHCTargetVersion
ver))
[[Char]]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO [[Char]]
listDirectoryFiles [Char]
bindir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
bindir [Char] -> [Char] -> [Char]
</>)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[([Char], [Char])]] -> [[Char]]
getUniqueTools forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[([Char], [Char])]]
groupToolFiles forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => [a] -> [a] -> [a]
dropSuffix [Char]
exeExt) forall a b. (a -> b) -> a -> b
$ [[Char]]
files)
where
groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
groupToolFiles :: [[Char]] -> [[([Char], [Char])]]
groupToolFiles = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\([Char]
a, [Char]
_) ([Char]
b, [Char]
_) -> [Char]
a forall a. Eq a => a -> a -> Bool
== [Char]
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> ([Char], [Char])
splitOnPVP [Char]
"-")
getUniqueTools :: [[(FilePath, String)]] -> [String]
getUniqueTools :: [[([Char], [Char])]] -> [[Char]]
getUniqueTools = forall a. (a -> Bool) -> [a] -> [a]
filter ([[Char]] -> [Char] -> Bool
isNotAnyInfix [[Char]]
blackListedTools) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== [Char]
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
blackListedTools :: [String]
blackListedTools :: [[Char]]
blackListedTools = [[Char]
"haddock-ghc"]
isNotAnyInfix :: [String] -> String -> Bool
isNotAnyInfix :: [[Char]] -> [Char] -> Bool
isNotAnyInfix [[Char]]
xs [Char]
t = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
a Bool
b -> Bool -> Bool
not ([Char]
a forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
t) Bool -> Bool -> Bool
&& Bool
b) Bool
True [[Char]]
xs
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile :: [Char]
ghcUpSrcBuiltFile = [Char]
".ghcup_src_built"
make :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
)
=> [String]
-> Maybe FilePath
-> m (Either ProcessError ())
make :: forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[[Char]] -> Maybe [Char] -> m (Either ProcessError ())
make [[Char]]
args Maybe [Char]
workdir = forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
make' [[Char]]
args Maybe [Char]
workdir [Char]
"ghc-make" forall a. Maybe a
Nothing
make' :: ( MonadThrow m
, MonadIO m
, MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
)
=> [String]
-> Maybe FilePath
-> FilePath
-> Maybe [(String, String)]
-> m (Either ProcessError ())
make' :: forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasDirs env,
HasLog env, HasSettings env) =>
[[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
make' [[Char]]
args Maybe [Char]
workdir [Char]
logfile Maybe [([Char], [Char])]
menv = do
[[Char]]
spaths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
Bool
has_gmake <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([[Char]] -> [Char] -> IO (Maybe [Char])
searchPath [[Char]]
spaths [Char]
"gmake")
let mymake :: [Char]
mymake = if Bool
has_gmake then [Char]
"gmake" else [Char]
"make"
forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
execLogged [Char]
mymake [[Char]]
args Maybe [Char]
workdir [Char]
logfile Maybe [([Char], [Char])]
menv
makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
=> [String]
-> Maybe FilePath
-> m CapturedProcess
makeOut :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
[[Char]] -> Maybe [Char] -> m CapturedProcess
makeOut [[Char]]
args Maybe [Char]
workdir = do
[[Char]]
spaths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Char]]
getSearchPath
Bool
has_gmake <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([[Char]] -> [Char] -> IO (Maybe [Char])
searchPath [[Char]]
spaths [Char]
"gmake")
let mymake :: [Char]
mymake = if Bool
has_gmake then [Char]
"gmake" else [Char]
"make"
forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
executeOut [Char]
mymake [[Char]]
args Maybe [Char]
workdir
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath
-> FilePath
-> Excepts '[PatchFailed] m ()
applyPatches :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatches [Char]
pdir [Char]
ddir = do
let lexicographical :: IO [[Char]]
lexicographical = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([Char]
pdir [Char] -> [Char] -> [Char]
</>) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Regex -> IO [[Char]]
findFiles
[Char]
pdir
(forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
ExecOption
execBlank
([s|.+\.(patch|diff)$|] :: ByteString)
)
let quilt :: IO [[Char]]
quilt = forall a b. (a -> b) -> [a] -> [b]
map ([Char]
pdir [Char] -> [Char] -> [Char]
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile ([Char]
pdir [Char] -> [Char] -> [Char]
</> [Char]
"series")
[[Char]]
patches <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO [[Char]]
quilt forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` (\IOException
e ->
if IOException -> Bool
isDoesNotExistError IOException
e Bool -> Bool -> Bool
|| IOException -> Bool
isPermissionError IOException
e then
IO [[Char]]
lexicographical
else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
patches forall a b. (a -> b) -> a -> b
$ \[Char]
patch' -> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch' [Char]
ddir
applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath
-> FilePath
-> Excepts '[PatchFailed] m ()
applyPatch :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch [Char]
ddir = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Applying patch " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
patch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just)
(forall (m :: * -> *).
MonadIO m =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
exec
[Char]
"patch"
[[Char]
"-p1", [Char]
"-s", [Char]
"-f", [Char]
"-i", [Char]
patch]
(forall a. a -> Maybe a
Just [Char]
ddir)
forall a. Maybe a
Nothing)
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
m (Maybe a) -> e -> Excepts es m a
!? PatchFailed
PatchFailed
applyAnyPatch :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadCatch m
, MonadResource m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> Maybe (Either FilePath [URI])
-> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
applyAnyPatch :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
Maybe (Either [Char] [URI])
-> [Char]
-> Excepts
'[PatchFailed, DownloadFailed, DigestError, ContentLengthError,
GPGError]
m
()
applyAnyPatch Maybe (Either [Char] [URI])
Nothing [Char]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
applyAnyPatch (Just (Left [Char]
pdir)) [Char]
workdir = forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatches [Char]
pdir [Char]
workdir
applyAnyPatch (Just (Right [URI]
uris)) [Char]
workdir = do
[Char]
tmpUnpack <- GHCupPath -> [Char]
fromGHCupPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [URI]
uris forall a b. (a -> b) -> a -> b
$ \URI
uri -> do
[Char]
patch <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> [Char]
-> Maybe [Char]
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
[Char]
download URI
uri forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Char]
tmpUnpack forall a. Maybe a
Nothing Bool
False
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadIO m) =>
[Char] -> [Char] -> Excepts '[PatchFailed] m ()
applyPatch [Char]
patch [Char]
workdir
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
=> Platform
-> FilePath
-> m (Either ProcessError ())
darwinNotarization :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m) =>
Platform -> [Char] -> m (Either ProcessError ())
darwinNotarization Platform
Darwin [Char]
path = forall (m :: * -> *).
MonadIO m =>
[Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> m (Either ProcessError ())
exec
[Char]
"xattr"
[[Char]
"-r", [Char]
"-d", [Char]
"com.apple.quarantine", [Char]
path]
forall a. Maybe a
Nothing
forall a. Maybe a
Nothing
darwinNotarization Platform
_ [Char]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog GHCupDownloads
dls Tool
tool (GHCVersion GHCTargetVersion
v') =
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v' forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolVersion (Version -> GHCTargetVersion
mkTVer -> GHCTargetVersion
v')) =
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v' forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolTag Tag
tag) =
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre (Tag
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged Tag
tag) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. (s -> a) -> Getter s a
to forall a b. (a, b) -> b
snd forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
getChangeLog GHCupDownloads
dls Tool
tool (ToolDay Day
day) =
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre (Day
-> Fold
(Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold Day
day) forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. (s -> a) -> Getter s a
to forall a b. (a, b) -> b
snd forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo (Maybe URI)
viChangeLog forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a b. Prism (Maybe a) (Maybe b) a b
_Just) GHCupDownloads
dls
runBuildAction :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath
-> Excepts e m a
-> Excepts e m a
runBuildAction :: forall env (m :: * -> *) (e :: IxList) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
runBuildAction GHCupPath
bdir Excepts e m a
action = do
Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let exAction :: m ()
exAction = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never)
forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
a
v <-
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never Bool -> Bool -> Bool
|| KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Errors) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
cleanUpOnError :: forall e m a env .
( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath
-> Excepts e m a
-> Excepts e m a
cleanUpOnError :: forall (e :: IxList) (m :: * -> *) a env.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanUpOnError GHCupPath
bdir Excepts e m a
action = do
Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let exAction :: m ()
exAction = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action
cleanFinally :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> GHCupPath
-> Excepts e m a
-> Excepts e m a
cleanFinally :: forall env (m :: * -> *) (e :: IxList) a.
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m,
MonadCatch m) =>
GHCupPath -> Excepts e m a -> Excepts e m a
cleanFinally GHCupPath
bdir Excepts e m a
action = do
Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let exAction :: m ()
exAction = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeepDirs
keepDirs forall a. Eq a => a -> a -> Bool
== KeepDirs
Never) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
bdir
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
exAction) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: IxList) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ m ()
exAction Excepts e m a
action
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
rmBDir :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) =>
GHCupPath -> m ()
rmBDir GHCupPath
dir = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Text
"Couldn't remove build dir " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath GHCupPath
dir) forall a. Semigroup a => a -> a -> a
<> Text
", error was: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall e. Exception e => e -> [Char]
displayException IOException
e))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmPathForcibly GHCupPath
dir)
getVersionInfo :: GHCTargetVersion
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo
getVersionInfo :: GHCTargetVersion -> Tool -> GHCupDownloads -> Maybe VersionInfo
getVersionInfo GHCTargetVersion
v' Tool
tool =
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Maybe a
headOf
( forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
tool
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. (s -> a) -> Getter s a
to (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\GHCTargetVersion
k VersionInfo
_ -> GHCTargetVersion
k forall a. Eq a => a -> a -> Bool
== GHCTargetVersion
v'))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. (s -> a) -> Getter s a
to forall k a. Map k a -> [a]
Map.elems
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a. Cons s s a a => AffineTraversal' s a
_head
)
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, HasSettings env
, HasGHCupInfo env
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools :: forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, HasSettings env, HasGHCupInfo env,
MonadUnliftIO m, MonadFail m) =>
Excepts
'[GPGError, DigestError, ContentLengthError, DownloadFailed,
NoDownload]
m
()
ensureGlobalTools
| Bool
isWindows = do
(GHCupInfo ToolRequirements
_ GHCupDownloads
_ Map GlobalTool DownloadInfo
gTools) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
Dirs
dirs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
DownloadInfo
shimDownload <- forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE @_ @'[NoDownload]
forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left NoDownload
NoDownload) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalTool
ShimGen Map GlobalTool DownloadInfo
gTools
let dl :: Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
[Char]
dl = forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe [Char]
-> Maybe [Char]
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
[Char]
downloadCached' DownloadInfo
shimDownload (forall a. a -> Maybe a
Just [Char]
"gs.exe") forall a. Maybe a
Nothing
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (\DigestError{} -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn Text
"Digest doesn't match, redownloading gs.exe..."
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (GHCupPath -> [Char]
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) [Char] -> [Char] -> [Char]
</> [Char]
"gs.exe"))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
[Char] -> m ()
recycleFile (GHCupPath -> [Char]
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) [Char] -> [Char] -> [Char]
</> [Char]
"gs.exe")
forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] forall a b. (a -> b) -> a -> b
$ Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
[Char]
dl
) forall e (es' :: IxList) (es'' :: IxList) (es :: IxList) a
(m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es',
LiftVariant es'' es') =>
(e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a
`catchE` forall (es' :: IxList) (es :: IxList) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
[Char]
dl
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensureDirectories :: Dirs -> IO ()
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs GHCupPath
baseDir [Char]
binDir GHCupPath
cacheDir GHCupPath
logsDir GHCupPath
confDir GHCupPath
trashDir GHCupPath
dbDir GHCupPath
tmpDir) = do
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir [Char] -> [Char] -> [Char]
</> [Char]
"ghc")
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
baseDir [Char] -> [Char] -> [Char]
</> [Char]
"hls")
[Char] -> IO ()
createDirRecursive' [Char]
binDir
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
cacheDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
logsDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
confDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
trashDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
dbDir)
[Char] -> IO ()
createDirRecursive' (GHCupPath -> [Char]
fromGHCupPath GHCupPath
tmpDir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName :: GHCTargetVersion -> [Char]
ghcBinaryName (GHCTargetVersion (Just Text
t) Version
_) = Text -> [Char]
T.unpack (Text
t forall a. Semigroup a => a -> a -> a
<> Text
"-ghc" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
exeExt)
ghcBinaryName (GHCTargetVersion Maybe Text
Nothing Version
_) = Text -> [Char]
T.unpack (Text
"ghc" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
exeExt)
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
, MonadMask m
) =>
InstallDirResolved ->
Excepts '[DirNotEmpty] m ()
installDestSanityCheck :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadMask m) =>
InstallDirResolved -> Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved [Char]
isoDir) = do
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] () forall a b. (a -> b) -> a -> b
$ do
Bool
empty' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => SerialT m a -> m Bool
S.null forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
[Char] -> SerialT m [Char]
getDirectoryContentsRecursiveUnsafe [Char]
isoDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
empty') (forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ [Char] -> DirNotEmpty
DirNotEmpty [Char]
isoDir)
installDestSanityCheck InstallDirResolved
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getInstalledFiles :: ( MonadIO m
, MonadCatch m
, MonadReader env m
, HasDirs env
, MonadFail m
)
=> Tool
-> GHCTargetVersion
-> m (Maybe [FilePath])
getInstalledFiles :: forall (m :: * -> *) env.
(MonadIO m, MonadCatch m, MonadReader env m, HasDirs env,
MonadFail m) =>
Tool -> GHCTargetVersion -> m (Maybe [[Char]])
getInstalledFiles Tool
t GHCTargetVersion
v' = forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
doesNotExistErrorType] forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
[Char]
f <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m [Char]
recordedInstallationFile Tool
t GHCTargetVersion
v'
(forall a. NFData a => a -> a
force -> ![Char]
c) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
([Char] -> IO [Char]
readFile [Char]
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
c)
warnAboutHlsCompatibility :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadThrow m
, MonadCatch m
, MonadIO m
)
=> m ()
warnAboutHlsCompatibility :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, MonadThrow m,
MonadCatch m, MonadIO m) =>
m ()
warnAboutHlsCompatibility = do
[Version]
supportedGHC <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m [Version]
hlsGHCVersions
Maybe Version
currentGHC <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHCTargetVersion -> Version
_tvVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) =>
Maybe Text -> m (Maybe GHCTargetVersion)
ghcSet forall a. Maybe a
Nothing
Maybe Version
currentHLS <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadThrow m,
MonadCatch m) =>
m (Maybe Version)
hlsSet
case (Maybe Version
currentGHC, Maybe Version
currentHLS) of
(Just Version
gv, Just Version
hv) | Version
gv forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
supportedGHC -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Text
"GHC-" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
gv) forall a. Semigroup a => a -> a -> a
<> Text
" appears to have no corresponding HLS-" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
hv) forall a. Semigroup a => a -> a -> a
<> Text
" binary." forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
"Haskell IDE support may not work." forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
"You can try to either: " forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
" 1. Install a different HLS version (e.g. downgrade for older GHCs)" forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
" 2. Install and set one of the following GHCs: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow [Version]
supportedGHC) forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
" 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
hv) forall a. Semigroup a => a -> a -> a
<> Text
" --ghc " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Pretty a => a -> [Char]
prettyShow Version
gv) forall a. Semigroup a => a -> a -> a
<> Text
" --cabal-update\n" forall a. Semigroup a => a -> a -> a
<>
Text
" (see https://www.haskell.org/ghcup/guide/#hls for more information)"
(Maybe Version, Maybe Version)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
addToPath :: FilePath
-> Bool
-> IO [(String, String)]
addToPath :: [Char] -> Bool -> IO [([Char], [Char])]
addToPath [Char]
path Bool
append = do
Map [Char] [Char]
cEnv <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [([Char], [Char])]
getEnvironment
let paths :: [[Char]]
paths = [[Char]
"PATH", [Char]
"Path"]
curPaths :: [[Char]]
curPaths = (\[Char]
x -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Char] -> [[Char]]
splitSearchPath (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
x Map [Char] [Char]
cEnv)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[Char]]
paths
newPath :: [Char]
newPath = forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] (if Bool
append then ([[Char]]
curPaths forall a. [a] -> [a] -> [a]
++ [[Char]
path]) else ([Char]
path forall a. a -> [a] -> [a]
: [[Char]]
curPaths))
envWithoutPath :: Map [Char] [Char]
envWithoutPath = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
x Map [Char] [Char]
y -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete [Char]
x Map [Char] [Char]
y) Map [Char] [Char]
cEnv [[Char]]
paths
pathVar :: [Char]
pathVar = if Bool
isWindows then [Char]
"Path" else [Char]
"PATH"
envWithNewPath :: [([Char], [Char])]
envWithNewPath = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
pathVar [Char]
newPath Map [Char] [Char]
envWithoutPath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
setEnv [Char]
pathVar [Char]
newPath
forall (m :: * -> *) a. Monad m => a -> m a
return [([Char], [Char])]
envWithNewPath
isCommitHash :: String -> Bool
isCommitHash :: [Char] -> Bool
isCommitHash [Char]
str' = let hex :: Bool
hex = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit [Char]
str'
len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str'
in Bool
hex Bool -> Bool -> Bool
&& Int
len forall a. Eq a => a -> a -> Bool
== Int
40
gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
gitOut :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m) =>
[[Char]] -> [Char] -> Excepts '[ProcessError] m Text
gitOut [[Char]]
args [Char]
dir = do
CapturedProcess {ByteString
ExitCode
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
$sel:_stdOut:CapturedProcess :: CapturedProcess -> ByteString
$sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
_stdErr :: ByteString
_stdOut :: ByteString
_exitCode :: ExitCode
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> Maybe [Char] -> m CapturedProcess
executeOut [Char]
"git" [[Char]]
args (forall a. a -> Maybe a
Just [Char]
dir)
case ExitCode
_exitCode of
ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stripNewlineEnd forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
_stdOut
ExitFailure Int
c -> do
let pe :: ProcessError
pe = Int -> [Char] -> [[Char]] -> ProcessError
NonZeroExit Int
c [Char]
"git" [[Char]]
args
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (forall e. (Pretty e, HFErrorProject e) => e -> [Char]
prettyHFError ProcessError
pe)
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE ProcessError
pe
processBranches :: T.Text -> [String]
processBranches :: Text -> [[Char]]
processBranches Text
str' = let lines' :: [[Char]]
lines' = [Char] -> [[Char]]
lines (Text -> [Char]
T.unpack Text
str')
words' :: [[[Char]]]
words' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [[Char]]
words [[Char]]
lines'
refs :: [[Char]]
refs = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> Int -> Maybe a
`atMay` Int
1) [[[Char]]]
words'
branches :: [[Char]]
branches = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"refs/heads/") forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"refs/heads/") [[Char]]
refs
in [[Char]]
branches