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