423 lines
15 KiB
Haskell
423 lines
15 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-|
|
|
Module : GHCup.List
|
|
Description : Listing versions and tools
|
|
Copyright : (c) Julian Ospald, 2020
|
|
License : LGPL-3.0
|
|
Maintainer : hasufell@hasufell.de
|
|
Stability : experimental
|
|
Portability : portable
|
|
-}
|
|
module GHCup.List where
|
|
|
|
import GHCup.Download
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Types.JSON ( )
|
|
import GHCup.Types.Optics
|
|
import GHCup.Utils
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Version
|
|
|
|
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 Data.Either
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Text ( Text )
|
|
import Data.Time.Calendar ( Day )
|
|
import Data.Versions hiding ( patch )
|
|
import Haskus.Utils.Variant.Excepts
|
|
import Optics
|
|
import Prelude hiding ( abs
|
|
, writeFile
|
|
)
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
------------------
|
|
--[ List tools ]--
|
|
------------------
|
|
|
|
|
|
-- | Filter data type for 'listVersions'.
|
|
data ListCriteria = ListInstalled Bool
|
|
| ListSet Bool
|
|
| ListAvailable Bool
|
|
deriving (Eq, Show)
|
|
|
|
-- | A list result describes a single tool version
|
|
-- and various of its properties.
|
|
data ListResult = ListResult
|
|
{ lTool :: Tool
|
|
, lVer :: Version
|
|
, lCross :: Maybe Text -- ^ currently only for GHC
|
|
, lTag :: [Tag]
|
|
, lInstalled :: Bool
|
|
, lSet :: Bool -- ^ currently active version
|
|
, lStray :: Bool -- ^ not in download info
|
|
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
|
|
, hlsPowered :: Bool
|
|
, lReleaseDay :: Maybe Day
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
|
|
-- | Extract all available tool versions and their tags.
|
|
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map GHCTargetVersion VersionInfo
|
|
availableToolVersions av tool = view
|
|
(at tool % non Map.empty)
|
|
av
|
|
|
|
|
|
-- | List all versions from the download info, as well as stray
|
|
-- versions.
|
|
listVersions :: ( MonadCatch m
|
|
, HasLog env
|
|
, MonadThrow m
|
|
, HasLog env
|
|
, MonadIO m
|
|
, MonadReader env m
|
|
, HasDirs env
|
|
, HasPlatformReq env
|
|
, HasGHCupInfo env
|
|
)
|
|
=> Maybe Tool
|
|
-> [ListCriteria]
|
|
-> Bool
|
|
-> Bool
|
|
-> (Maybe Day, Maybe Day)
|
|
-> m [ListResult]
|
|
listVersions lt' criteria hideOld showNightly days = do
|
|
-- some annoying work to avoid too much repeated IO
|
|
cSet <- cabalSet
|
|
cabals <- getInstalledCabals
|
|
hlsSet' <- hlsSet
|
|
hlses <- getInstalledHLSs
|
|
sSet <- stackSet
|
|
stacks <- getInstalledStacks
|
|
|
|
go lt' cSet cabals hlsSet' hlses sSet stacks
|
|
where
|
|
go lt cSet cabals hlsSet' hlses sSet stacks = do
|
|
case lt of
|
|
Just t -> do
|
|
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
|
-- get versions from GHCupDownloads
|
|
let avTools = availableToolVersions dls t
|
|
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
|
|
|
|
case t of
|
|
GHC -> do
|
|
slr <- strayGHCs avTools
|
|
pure (sort (slr ++ lr))
|
|
Cabal -> do
|
|
slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals
|
|
pure (sort (slr ++ lr))
|
|
HLS -> do
|
|
slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses
|
|
pure (sort (slr ++ lr))
|
|
Stack -> do
|
|
slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks
|
|
pure (sort (slr ++ lr))
|
|
GHCup -> do
|
|
let cg = maybeToList $ currentGHCup avTools
|
|
pure (sort (cg ++ lr))
|
|
Nothing -> do
|
|
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
|
|
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
|
|
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
|
|
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
|
|
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
|
|
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
|
|
strayGHCs :: ( MonadCatch m
|
|
, MonadReader env m
|
|
, HasDirs env
|
|
, MonadThrow m
|
|
, HasLog env
|
|
, MonadIO m
|
|
)
|
|
=> Map.Map GHCTargetVersion VersionInfo
|
|
-> m [ListResult]
|
|
strayGHCs avTools = do
|
|
ghcs <- getInstalledGHCs
|
|
fmap catMaybes $ forM ghcs $ \case
|
|
Right tver@GHCTargetVersion{ .. } -> do
|
|
case Map.lookup tver avTools of
|
|
Just _ -> pure Nothing
|
|
Nothing -> do
|
|
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
|
|
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
|
|
pure $ Just $ ListResult
|
|
{ lTool = GHC
|
|
, lVer = _tvVersion
|
|
, lCross = _tvTarget
|
|
, lTag = []
|
|
, lInstalled = True
|
|
, lStray = isNothing (Map.lookup tver avTools)
|
|
, lNoBindist = False
|
|
, lReleaseDay = Nothing
|
|
, ..
|
|
}
|
|
Left e -> do
|
|
logWarn
|
|
$ "Could not parse version of stray directory" <> T.pack e
|
|
pure Nothing
|
|
|
|
strayCabals :: ( MonadReader env m
|
|
, HasDirs env
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, HasLog env
|
|
, MonadIO m
|
|
)
|
|
=> Map.Map Version VersionInfo
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> m [ListResult]
|
|
strayCabals avTools cSet cabals = do
|
|
fmap catMaybes $ forM cabals $ \case
|
|
Right ver ->
|
|
case Map.lookup ver avTools of
|
|
Just _ -> pure Nothing
|
|
Nothing -> do
|
|
let lSet = cSet == Just ver
|
|
pure $ Just $ ListResult
|
|
{ lTool = Cabal
|
|
, lVer = ver
|
|
, lCross = Nothing
|
|
, lTag = []
|
|
, lInstalled = True
|
|
, lStray = isNothing (Map.lookup ver avTools)
|
|
, lNoBindist = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = Nothing
|
|
, ..
|
|
}
|
|
Left e -> do
|
|
logWarn
|
|
$ "Could not parse version of stray directory" <> T.pack e
|
|
pure Nothing
|
|
|
|
strayHLS :: ( MonadReader env m
|
|
, HasDirs env
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, HasLog env
|
|
, MonadIO m)
|
|
=> Map.Map Version VersionInfo
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> m [ListResult]
|
|
strayHLS avTools hlsSet' hlss = do
|
|
fmap catMaybes $ forM hlss $ \case
|
|
Right ver ->
|
|
case Map.lookup ver avTools of
|
|
Just _ -> pure Nothing
|
|
Nothing -> do
|
|
let lSet = hlsSet' == Just ver
|
|
pure $ Just $ ListResult
|
|
{ lTool = HLS
|
|
, lVer = ver
|
|
, lCross = Nothing
|
|
, lTag = []
|
|
, lInstalled = True
|
|
, lStray = isNothing (Map.lookup ver avTools)
|
|
, lNoBindist = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = Nothing
|
|
, ..
|
|
}
|
|
Left e -> do
|
|
logWarn
|
|
$ "Could not parse version of stray directory" <> T.pack e
|
|
pure Nothing
|
|
|
|
strayStacks :: ( MonadReader env m
|
|
, HasDirs env
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, HasLog env
|
|
, MonadIO m
|
|
)
|
|
=> Map.Map Version VersionInfo
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> m [ListResult]
|
|
strayStacks avTools stackSet' stacks = do
|
|
fmap catMaybes $ forM stacks $ \case
|
|
Right ver ->
|
|
case Map.lookup ver avTools of
|
|
Just _ -> pure Nothing
|
|
Nothing -> do
|
|
let lSet = stackSet' == Just ver
|
|
pure $ Just $ ListResult
|
|
{ lTool = Stack
|
|
, lVer = ver
|
|
, lCross = Nothing
|
|
, lTag = []
|
|
, lInstalled = True
|
|
, lStray = isNothing (Map.lookup ver avTools)
|
|
, lNoBindist = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = Nothing
|
|
, ..
|
|
}
|
|
Left e -> do
|
|
logWarn
|
|
$ "Could not parse version of stray directory" <> T.pack e
|
|
pure Nothing
|
|
|
|
currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult
|
|
currentGHCup av =
|
|
let currentVer = mkTVer $ fromJust $ pvpToVersion ghcUpVer ""
|
|
listVer = Map.lookup currentVer av
|
|
latestVer = fst <$> headOf (getTagged Latest) av
|
|
recommendedVer = fst <$> headOf (getTagged Latest) av
|
|
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
|
|
in if | Map.member currentVer av -> Nothing
|
|
| otherwise -> Just $ ListResult { lVer = _tvVersion currentVer
|
|
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
|
|
, lCross = Nothing
|
|
, lTool = GHCup
|
|
, lStray = isNothing listVer
|
|
, lSet = True
|
|
, lInstalled = True
|
|
, lNoBindist = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = Nothing
|
|
}
|
|
|
|
-- NOTE: this are not cross ones, because no bindists
|
|
toListResult :: ( HasLog env
|
|
, MonadReader env m
|
|
, HasDirs env
|
|
, HasGHCupInfo env
|
|
, HasPlatformReq env
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Tool
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> Maybe Version
|
|
-> [Either FilePath Version]
|
|
-> (GHCTargetVersion, VersionInfo)
|
|
-> m ListResult
|
|
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do
|
|
let v = _tvVersion tver
|
|
case t of
|
|
GHC -> do
|
|
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
|
|
lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
|
|
lInstalled <- ghcInstalled tver
|
|
hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
|
|
pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
|
|
Cabal -> do
|
|
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
|
|
let lSet = cSet == Just v
|
|
let lInstalled = elem v $ rights cabals
|
|
pure ListResult { lVer = v
|
|
, lCross = Nothing
|
|
, lTag = _viTags
|
|
, lTool = t
|
|
, lStray = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = _viReleaseDay
|
|
, ..
|
|
}
|
|
GHCup -> do
|
|
let lSet = prettyPVP ghcUpVer == prettyVer v
|
|
let lInstalled = lSet
|
|
pure ListResult { lVer = v
|
|
, lTag = _viTags
|
|
, lCross = Nothing
|
|
, lTool = t
|
|
, lStray = False
|
|
, lNoBindist = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = _viReleaseDay
|
|
, ..
|
|
}
|
|
HLS -> do
|
|
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v
|
|
let lSet = hlsSet' == Just v
|
|
let lInstalled = elem v $ rights hlses
|
|
pure ListResult { lVer = v
|
|
, lCross = Nothing
|
|
, lTag = _viTags
|
|
, lTool = t
|
|
, lStray = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = _viReleaseDay
|
|
, ..
|
|
}
|
|
Stack -> do
|
|
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v
|
|
let lSet = stackSet' == Just v
|
|
let lInstalled = elem v $ rights stacks
|
|
pure ListResult { lVer = v
|
|
, lCross = Nothing
|
|
, lTag = _viTags
|
|
, lTool = t
|
|
, lStray = False
|
|
, hlsPowered = False
|
|
, lReleaseDay = _viReleaseDay
|
|
, ..
|
|
}
|
|
|
|
|
|
filter' :: [ListResult] -> [ListResult]
|
|
filter' = filterNightly . filterOld . filter (\lr -> foldr (\a b -> fromCriteria a lr && b) True criteria) . filterDays
|
|
|
|
filterDays :: [ListResult] -> [ListResult]
|
|
filterDays lrs = case days of
|
|
(Nothing, Nothing) -> lrs
|
|
(Just from, Just to') -> filter (\ListResult{..} -> maybe False (\d -> d >= from && d <= to') lReleaseDay) lrs
|
|
(Nothing, Just to') -> filter (\ListResult{..} -> maybe False (<= to') lReleaseDay) lrs
|
|
(Just from, Nothing) -> filter (\ListResult{..} -> maybe False (>= from) lReleaseDay) lrs
|
|
|
|
fromCriteria :: ListCriteria -> ListResult -> Bool
|
|
fromCriteria lc ListResult{..} = case lc of
|
|
ListInstalled b -> f b lInstalled
|
|
ListSet b -> f b lSet
|
|
ListAvailable b -> f b $ not lNoBindist
|
|
where
|
|
f b
|
|
| b = id
|
|
| otherwise = not
|
|
|
|
filterOld :: [ListResult] -> [ListResult]
|
|
filterOld lr
|
|
| hideOld = filter (\ListResult {..} -> lInstalled || Old `notElem` lTag) lr
|
|
| otherwise = lr
|
|
|
|
filterNightly :: [ListResult] -> [ListResult]
|
|
filterNightly lr
|
|
| showNightly = lr
|
|
| otherwise = filter (\ListResult {..} -> lInstalled || (Nightly `notElem` lTag && LatestNightly `notElem` lTag)) lr
|
|
|