WIP
This commit is contained in:
parent
e0222b4007
commit
ff60744cc6
@ -9,7 +9,7 @@ constraints: http-io-streams -brotli,
|
||||
any.aeson >= 2.0.1.0
|
||||
|
||||
package libarchive
|
||||
flags: -system-libarchive
|
||||
flags: +system-libarchive
|
||||
|
||||
package aeson-pretty
|
||||
flags: +lib-only
|
||||
|
@ -177,7 +177,7 @@ installCabalBin :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> InstallDir
|
||||
-> Bool -- force install
|
||||
-> Excepts
|
||||
@ -198,7 +198,7 @@ installCabalBin :: ( MonadMask m
|
||||
()
|
||||
installCabalBin ver installDir forceInstall = do
|
||||
dlinfo <- liftE $ getDownloadInfo Cabal ver
|
||||
installCabalBindist dlinfo ver installDir forceInstall
|
||||
installCabalBindist dlinfo (vVersion ver) installDir forceInstall
|
||||
|
||||
|
||||
-----------------
|
||||
|
@ -277,20 +277,19 @@ getDownloadInfo :: ( MonadReader env m
|
||||
, HasGHCupInfo env
|
||||
)
|
||||
=> Tool
|
||||
-> Version
|
||||
-> VersionRev
|
||||
-- ^ tool version
|
||||
-> Excepts
|
||||
'[NoDownload]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo t v = do
|
||||
getDownloadInfo t (VersionRev v vr) = do
|
||||
(PlatformRequest a p mv) <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
let distro_preview f g =
|
||||
let platformVersionSpec =
|
||||
-- TODO
|
||||
preview (ix t % ix v % viDownload % ix 0 % viArch % ix a % ix (f p)) dls
|
||||
preview (ix t % ix v % viDownload % ix vr % viArch % ix a % ix (f p)) dls
|
||||
mv' = g mv
|
||||
in fmap snd
|
||||
. find
|
||||
|
@ -78,6 +78,7 @@ import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
|
||||
data GHCVer v = SourceDist v
|
||||
@ -105,7 +106,7 @@ testGHCVer :: ( MonadFail m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> [T.Text]
|
||||
-> Excepts
|
||||
'[ DigestError
|
||||
@ -120,12 +121,11 @@ testGHCVer :: ( MonadFail m
|
||||
]
|
||||
m
|
||||
()
|
||||
testGHCVer ver addMakeArgs = do
|
||||
testGHCVer (VersionRev ver vr) addMakeArgs = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
|
||||
dlInfo <-
|
||||
-- TODO
|
||||
preview (ix GHC % ix ver % viDownload % ix 0 % viTestDL % _Just) dls
|
||||
preview (ix GHC % ix ver % viDownload % to M.toAscList % maybe _last ix vr % to snd % viTestDL % _Just) dls
|
||||
?? NoDownload
|
||||
|
||||
liftE $ testGHCBindist dlInfo ver addMakeArgs
|
||||
@ -244,7 +244,7 @@ fetchGHCSrc :: ( MonadFail m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
'[ DigestError
|
||||
@ -255,11 +255,10 @@ fetchGHCSrc :: ( MonadFail m
|
||||
]
|
||||
m
|
||||
FilePath
|
||||
fetchGHCSrc v mfp = do
|
||||
fetchGHCSrc (VersionRev v vr) mfp = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
dlInfo <-
|
||||
-- TODO
|
||||
preview (ix GHC % ix v % viDownload % ix 0 % viSourceDL % _Just) dls
|
||||
preview (ix GHC % ix v % viDownload % to M.toAscList % maybe _last ix vr % to snd % viSourceDL % _Just) dls
|
||||
?? NoDownload
|
||||
liftE $ downloadCached' dlInfo Nothing mfp
|
||||
|
||||
@ -806,8 +805,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <-
|
||||
-- TODO
|
||||
preview (ix GHC % ix (tver ^. tvVersion) % viDownload % ix 0 % viSourceDL % _Just) dls
|
||||
preview (ix GHC % ix (tver ^. tvVersion) % viDownload % _last % viSourceDL % _Just) dls
|
||||
?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
|
@ -368,8 +368,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <-
|
||||
-- TODO
|
||||
preview (ix HLS % ix tver % viDownload % ix 0 % viSourceDL % _Just) dls
|
||||
preview (ix HLS % ix tver % viDownload % _last % viSourceDL % _Just) dls
|
||||
?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
|
@ -28,6 +28,8 @@ import System.FilePath
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
import Data.Char (digitToInt)
|
||||
import Data.Data (Proxy(..))
|
||||
|
||||
|
||||
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
|
||||
@ -86,7 +88,33 @@ ghcTargetVerP =
|
||||
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
|
||||
<|> ((\ _ x -> x) Nothing <$> mempty)
|
||||
)
|
||||
<*> (version' <* MP.eof)
|
||||
<*> version'
|
||||
where
|
||||
verP' :: MP.Parsec Void Text Text
|
||||
verP' = do
|
||||
v <- version'
|
||||
let startsWithDigists =
|
||||
and
|
||||
. take 3
|
||||
. concatMap
|
||||
(map
|
||||
(\case
|
||||
(Digits _) -> True
|
||||
(Str _) -> False
|
||||
) . NE.toList)
|
||||
. NE.toList
|
||||
$ _vChunks v
|
||||
if startsWithDigists && isNothing (_vEpoch v)
|
||||
then pure $ prettyVer v
|
||||
else fail "Oh"
|
||||
|
||||
ghcTargetVerRevP :: MP.Parsec Void Text GHCTargetVersionRev
|
||||
ghcTargetVerRevP =
|
||||
(\x y -> GHCTargetVersionRev x y)
|
||||
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
|
||||
<|> ((\ _ x -> x) Nothing <$> mempty)
|
||||
)
|
||||
<*> versionRevP
|
||||
where
|
||||
verP' :: MP.Parsec Void Text Text
|
||||
verP' = do
|
||||
@ -122,3 +150,44 @@ verP suffix = do
|
||||
|
||||
pathSep :: MP.Parsec Void Text Char
|
||||
pathSep = MP.oneOf pathSeparators
|
||||
|
||||
versionRevP :: MP.Parsec Void Text VersionRev
|
||||
versionRevP = MP.label "versionRev" $
|
||||
MP.try (parseUntil (MP.try (MP.chunk "-r")) >>= versionWithRev) <|> ((`VersionRev` 0) <$> version')
|
||||
where
|
||||
versionWithRev ver = do
|
||||
rest <- MP.getInput
|
||||
MP.setInput ver
|
||||
v <- version'
|
||||
MP.setInput rest
|
||||
_ <- MP.chunk "-r"
|
||||
rev <- parseInt
|
||||
pure $ VersionRev v rev
|
||||
|
||||
digit = MP.oneOf ['0'..'9'] MP.<?> "digit"
|
||||
parseInt :: MP.Parsec Void Text Int
|
||||
parseInt = MP.label "parseInt" $ do
|
||||
i <- MP.tokensToChunk (Proxy :: Proxy Text) <$> some digit
|
||||
pure $ numberValue 10 $ T.unpack i
|
||||
|
||||
numberValue :: Int -> String -> Int
|
||||
numberValue base = foldl (\ x -> ((fromIntegral base * x) +) . fromIntegral . digitToInt) 0
|
||||
|
||||
userVersionRevP :: MP.Parsec Void Text UserVersionRev
|
||||
userVersionRevP = MP.label "userVersionRev" $
|
||||
((\(VersionRev v r) -> UserVersionRev v (Just r)) <$> MP.try versionRevP) <|> ((`UserVersionRev` Nothing) <$> version')
|
||||
|
||||
|
||||
-- | Read a @VersionRev@ from a String.
|
||||
--
|
||||
-- - 3.3.2 -> VersionRev { vVersion = 3.3.3, vRev = 0 }
|
||||
-- - 2.3.4-r3 -> VersionRev { vVersion = 2.3.4, vRev = 3 }
|
||||
versionRev :: Text -> Either (MP.ParseErrorBundle Text Void) VersionRev
|
||||
versionRev = MP.parse versionRevP ""
|
||||
|
||||
-- | Read a @UserVersionRev@ from a String.
|
||||
--
|
||||
-- - 3.3.2 -> UserVersionRev { vVersion = 3.3.3, vRev = Nothing }
|
||||
-- - 2.3.4-r3 -> UserVersionRev { vVersion = 2.3.4, vRev = Just 3 }
|
||||
userVersionRev :: Text -> Either (MP.ParseErrorBundle Text Void) UserVersionRev
|
||||
userVersionRev = MP.parse userVersionRevP ""
|
||||
|
@ -181,6 +181,30 @@ fromVersionInfoLegacy VersionInfoLegacy{..} =
|
||||
, ..}
|
||||
|
||||
|
||||
-- | A version with a revision, denoting bindist 'versions' that are purely distribution specific.
|
||||
--
|
||||
-- The revision starts at 0.
|
||||
data VersionRev = VersionRev { vVersion :: Version, vRev :: Int }
|
||||
deriving (Ord, Eq, GHC.Generic, Show)
|
||||
|
||||
showVersionRev :: VersionRev -> Text
|
||||
showVersionRev (VersionRev v 0) = prettyVer v
|
||||
showVersionRev (VersionRev v r) = prettyVer v <> "-r" <> T.pack (show r)
|
||||
|
||||
-- | Similar to @VersionRev@, except that revision is optional. The absence of a revision has
|
||||
-- a particular meaning:
|
||||
--
|
||||
-- * for install/prefetch: we want the latest available revision
|
||||
-- * for compile: it depends
|
||||
-- * for rm/set/unset/whereis/changelog: we want the revision that is installed (there can be only one)
|
||||
--
|
||||
-- Translating @UserVersionRev@ to @VersionRev@ requires context of the GHCup metadata,
|
||||
-- installed versions and the to be executed command.
|
||||
data UserVersionRev = UserVersionRev { uvVersion :: Version, uvRev :: Maybe Int }
|
||||
deriving (Ord, Eq, GHC.Generic, Show)
|
||||
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
@ -617,12 +641,6 @@ data GHCTargetVersion = GHCTargetVersion
|
||||
}
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
data GitBranch = GitBranch
|
||||
{ ref :: String
|
||||
, repo :: Maybe String
|
||||
}
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
mkTVer :: Version -> GHCTargetVersion
|
||||
mkTVer = GHCTargetVersion Nothing
|
||||
|
||||
@ -630,10 +648,30 @@ tVerToText :: GHCTargetVersion -> Text
|
||||
tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
|
||||
tVerToText (GHCTargetVersion Nothing v') = prettyVer v'
|
||||
|
||||
-- | A GHC identified by the target platform triple
|
||||
-- and the version.
|
||||
data GHCTargetVersionRev = GHCTargetVersionRev
|
||||
{ _tvTargetRev :: Maybe Text
|
||||
, _tvVersionRev :: VersionRev
|
||||
}
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
mkTVerRev :: VersionRev -> GHCTargetVersionRev
|
||||
mkTVerRev = GHCTargetVersionRev Nothing
|
||||
|
||||
tVerRevToText :: GHCTargetVersionRev -> Text
|
||||
tVerRevToText (GHCTargetVersionRev (Just t) v') = t <> "-" <> showVersionRev v'
|
||||
tVerRevToText (GHCTargetVersionRev Nothing v') = showVersionRev v'
|
||||
|
||||
-- | Assembles a path of the form: <target-triple>-<version>
|
||||
instance Pretty GHCTargetVersion where
|
||||
pPrint = text . T.unpack . tVerToText
|
||||
|
||||
data GitBranch = GitBranch
|
||||
{ ref :: String
|
||||
, repo :: Maybe String
|
||||
}
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
-- | A comparator and a version.
|
||||
data VersionCmp = VR_gt Versioning
|
||||
|
@ -228,7 +228,7 @@ rmMinorHLSSymlinks :: ( MonadReader env m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMinorHLSSymlinks ver = do
|
||||
Dirs {..} <- lift getDirs
|
||||
@ -281,7 +281,7 @@ rmPlainHLS = do
|
||||
-----------------------------------
|
||||
|
||||
|
||||
-- | Whether the given GHC versin is installed.
|
||||
-- | Whether the given GHC version is installed.
|
||||
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
@ -299,7 +299,7 @@ ghcSrcInstalled ver = do
|
||||
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Maybe Text -- ^ the target of the GHC version, if any
|
||||
-- (e.g. armv7-unknown-linux-gnueabihf)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
-> m (Maybe GHCTargetVersionRev)
|
||||
ghcSet mtarget = do
|
||||
Dirs {..} <- getDirs
|
||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
||||
@ -311,7 +311,7 @@ ghcSet mtarget = do
|
||||
link <- liftIO $ getLinkTarget ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
where
|
||||
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersionRev
|
||||
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
where
|
||||
parser =
|
||||
@ -321,7 +321,7 @@ ghcSet mtarget = do
|
||||
r <- parseUntil1 pathSep
|
||||
rest <- MP.getInput
|
||||
MP.setInput r
|
||||
x <- ghcTargetVerP
|
||||
x <- ghcTargetVerRevP
|
||||
MP.setInput rest
|
||||
pure x
|
||||
)
|
||||
@ -347,13 +347,13 @@ getInstalledCabals :: ( MonadReader env m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> m [Either FilePath Version]
|
||||
=> m [Either FilePath VersionRev]
|
||||
getInstalledCabals = do
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
|
||||
vs <- forM bins $ \f -> case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
@ -361,14 +361,14 @@ getInstalledCabals = do
|
||||
|
||||
|
||||
-- | Whether the given cabal version is installed.
|
||||
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
|
||||
cabalInstalled ver = do
|
||||
vers <- fmap rights getInstalledCabals
|
||||
pure $ elem ver vers
|
||||
|
||||
|
||||
-- Return the currently set cabal version, if any.
|
||||
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
|
||||
cabalSet = do
|
||||
Dirs {..} <- getDirs
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
@ -395,7 +395,7 @@ cabalSet = do
|
||||
-- We try to be extra permissive with link destination parsing,
|
||||
-- because of:
|
||||
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion :: MonadThrow m => FilePath -> m VersionRev
|
||||
linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt
|
||||
|
||||
parser
|
||||
@ -403,7 +403,7 @@ cabalSet = do
|
||||
<|> MP.try (stripRelativePath *> cabalParse)
|
||||
<|> cabalParse
|
||||
-- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
|
||||
cabalParse = MP.chunk "cabal-" *> version'
|
||||
cabalParse = MP.chunk "cabal-" *> versionRevP
|
||||
-- parses any path component ending with path separator,
|
||||
-- e.g. "foo/"
|
||||
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
|
||||
@ -420,7 +420,7 @@ cabalSet = do
|
||||
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
|
||||
-- as well as @~\/.ghcup\/hls\/<\hlsver\>@
|
||||
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
=> m [Either FilePath VersionRev]
|
||||
getInstalledHLSs = do
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@ -431,7 +431,7 @@ getInstalledHLSs = do
|
||||
)
|
||||
legacy <- forM bins $ \f ->
|
||||
case
|
||||
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
|
||||
versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
@ -448,7 +448,7 @@ getInstalledHLSs = do
|
||||
-- | Get all installed stacks, by matching on
|
||||
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
|
||||
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
=> m [Either FilePath VersionRev]
|
||||
getInstalledStacks = do
|
||||
Dirs {..} <- getDirs
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@ -458,7 +458,7 @@ getInstalledStacks = do
|
||||
([s|^stack-.*$|] :: ByteString)
|
||||
)
|
||||
forM bins $ \f ->
|
||||
case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
|
||||
case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
@ -509,13 +509,13 @@ stackSet = do
|
||||
stripRelativePath = MP.many (MP.try stripPathComponet)
|
||||
|
||||
-- | Whether the given Stack version is installed.
|
||||
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
|
||||
stackInstalled ver = do
|
||||
vers <- fmap rights getInstalledStacks
|
||||
pure $ elem ver vers
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
|
||||
hlsInstalled ver = do
|
||||
vers <- fmap rights getInstalledHLSs
|
||||
pure $ elem ver vers
|
||||
@ -527,7 +527,7 @@ isLegacyHLS ver = do
|
||||
|
||||
|
||||
-- Return the currently set hls version, if any.
|
||||
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
|
||||
hlsSet = do
|
||||
Dirs {..} <- getDirs
|
||||
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
@ -540,7 +540,7 @@ hlsSet = do
|
||||
link <- liftIO $ getLinkTarget hlsBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion :: MonadThrow m => FilePath -> m VersionRev
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
where
|
||||
parser
|
||||
@ -548,7 +548,7 @@ hlsSet = do
|
||||
<|> MP.try (stripRelativePath *> cabalParse)
|
||||
<|> cabalParse
|
||||
-- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
|
||||
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
|
||||
cabalParse = MP.chunk "haskell-language-server-wrapper-" *> versionRevP
|
||||
-- parses any path component ending with path separator,
|
||||
-- e.g. "foo/"
|
||||
stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
|
||||
@ -567,7 +567,7 @@ hlsGHCVersions :: ( MonadReader env m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> m [Version]
|
||||
=> m [VersionRev]
|
||||
hlsGHCVersions = do
|
||||
h <- hlsSet
|
||||
fromMaybe [] <$> forM h hlsGHCVersions'
|
||||
@ -579,12 +579,12 @@ hlsGHCVersions' :: ( MonadReader env m
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Version
|
||||
-> m [Version]
|
||||
=> VersionRev
|
||||
-> m [VersionRev]
|
||||
hlsGHCVersions' v' = do
|
||||
bins <- hlsServerBinaries v' Nothing
|
||||
let vers = fmap
|
||||
(version
|
||||
(versionRev
|
||||
. T.pack
|
||||
. fromJust
|
||||
. stripPrefix "haskell-language-server-"
|
||||
@ -597,10 +597,10 @@ hlsGHCVersions' v' = do
|
||||
|
||||
-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
|
||||
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> Maybe Version -- ^ optional GHC version
|
||||
-> m [FilePath]
|
||||
hlsServerBinaries ver mghcVer = do
|
||||
hlsServerBinaries (VersionRev ver rv) mghcVer = do
|
||||
Dirs {..} <- getDirs
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
@ -611,6 +611,7 @@ hlsServerBinaries ver mghcVer = do
|
||||
<> maybe [s|.*|] escapeVerRex mghcVer
|
||||
<> [s|~|]
|
||||
<> escapeVerRex ver
|
||||
<> E.encodeUtf8 (T.pack ("-r" <> show rv))
|
||||
<> E.encodeUtf8 (T.pack exeExt)
|
||||
<> [s|$|] :: ByteString
|
||||
)
|
||||
@ -657,16 +658,20 @@ hlsInternalServerLibs ver ghcVer = do
|
||||
|
||||
-- | Get the wrapper binary for an hls version, if any.
|
||||
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
|
||||
=> Version
|
||||
=> VersionRev
|
||||
-> m (Maybe FilePath)
|
||||
hlsWrapperBinary ver = do
|
||||
hlsWrapperBinary (VersionRev ver rv) = do
|
||||
Dirs {..} <- getDirs
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
|
||||
([s|^haskell-language-server-wrapper-|]
|
||||
<> escapeVerRex ver
|
||||
<> E.encodeUtf8 (T.pack ("-r" <> show rv))
|
||||
<> E.encodeUtf8 (T.pack exeExt)
|
||||
<> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
case wrapper of
|
||||
@ -677,7 +682,7 @@ hlsWrapperBinary ver = do
|
||||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => VersionRev -> m [FilePath]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver Nothing
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
@ -930,7 +935,7 @@ ghcInternalBinDir ver = do
|
||||
--
|
||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
||||
ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
=> GHCTargetVersionRev
|
||||
-> Excepts '[NotInstalled] m [FilePath]
|
||||
ghcToolFiles ver = do
|
||||
bindir <- ghcInternalBinDir ver
|
||||
@ -1288,7 +1293,7 @@ warnAboutHlsCompatibility :: ( MonadReader env m
|
||||
=> m ()
|
||||
warnAboutHlsCompatibility = do
|
||||
supportedGHC <- hlsGHCVersions
|
||||
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
|
||||
currentGHC <- fmap _tvVersionRev <$> ghcSet Nothing
|
||||
currentHLS <- hlsSet
|
||||
|
||||
case (currentGHC, currentHLS) of
|
||||
|
@ -417,9 +417,9 @@ parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (T.pack -> fp) =
|
||||
throwEither $ MP.parse ghcTargetVerP "" fp
|
||||
|
||||
parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
|
||||
parseGHCupHLSDir :: MonadThrow m => FilePath -> m VersionRev
|
||||
parseGHCupHLSDir (T.pack -> fp) =
|
||||
throwEither $ MP.parse version' "" fp
|
||||
throwEither $ versionRev fp
|
||||
|
||||
-- TODO: inlined from GHCup.Prelude
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
|
Loading…
Reference in New Issue
Block a user