425 lines
11 KiB
Haskell
425 lines
11 KiB
Haskell
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
{-|
|
|
Module : GHCup.Types
|
|
Description : GHCup types
|
|
Copyright : (c) Julian Ospald, 2020
|
|
License : LGPL-3.0
|
|
Maintainer : hasufell@hasufell.de
|
|
Stability : experimental
|
|
Portability : POSIX
|
|
-}
|
|
module GHCup.Types where
|
|
|
|
import Data.Map.Strict ( Map )
|
|
import Data.List.NonEmpty ( NonEmpty (..) )
|
|
import Data.String.Interpolate
|
|
import Data.Text ( Text )
|
|
import Data.Versions
|
|
import HPath
|
|
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
|
|
import URI.ByteString
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import qualified Data.Text.Encoding.Error as E
|
|
import qualified GHC.Generics as GHC
|
|
import qualified Graphics.Vty as Vty
|
|
|
|
|
|
|
|
--------------------
|
|
--[ GHCInfo Tree ]--
|
|
--------------------
|
|
|
|
|
|
data GHCupInfo = GHCupInfo
|
|
{ _toolRequirements :: ToolRequirements
|
|
, _ghcupDownloads :: GHCupDownloads
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
|
|
|
|
-------------------------
|
|
--[ Requirements Tree ]--
|
|
-------------------------
|
|
|
|
|
|
type ToolRequirements = Map Tool ToolReqVersionSpec
|
|
type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
|
|
type PlatformReqSpec = Map Platform PlatformReqVersionSpec
|
|
type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements
|
|
|
|
|
|
data Requirements = Requirements
|
|
{ _distroPKGs :: [Text]
|
|
, _notes :: Text
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
|
|
|
|
|
|
|
|
---------------------
|
|
--[ Download Tree ]--
|
|
---------------------
|
|
|
|
|
|
-- | Description of all binary and source downloads. This is a tree
|
|
-- of nested maps.
|
|
type GHCupDownloads = Map Tool ToolVersionSpec
|
|
type ToolVersionSpec = Map Version VersionInfo
|
|
type ArchitectureSpec = Map Architecture PlatformSpec
|
|
type PlatformSpec = Map Platform PlatformVersionSpec
|
|
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
|
|
|
|
|
|
-- | An installable tool.
|
|
data Tool = GHC
|
|
| Cabal
|
|
| GHCup
|
|
| HLS
|
|
| Stack
|
|
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
|
|
|
|
|
-- | All necessary information of a tool version, including
|
|
-- source download and per-architecture downloads.
|
|
data VersionInfo = VersionInfo
|
|
{ _viTags :: [Tag] -- ^ version specific tag
|
|
, _viChangeLog :: Maybe URI
|
|
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
|
|
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
|
|
-- informative messages
|
|
, _viPostInstall :: Maybe Text
|
|
, _viPostRemove :: Maybe Text
|
|
, _viPreCompile :: Maybe Text
|
|
}
|
|
deriving (Eq, GHC.Generic, Show)
|
|
|
|
|
|
-- | A tag. These are currently attached to a version of a tool.
|
|
data Tag = Latest
|
|
| Recommended
|
|
| Prerelease
|
|
| Base PVP
|
|
| Old -- ^ old version are hidden by default in TUI
|
|
| UnknownTag String -- ^ used for upwardscompat
|
|
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
|
|
|
|
tagToString :: Tag -> String
|
|
tagToString Recommended = "recommended"
|
|
tagToString Latest = "latest"
|
|
tagToString Prerelease = "prerelease"
|
|
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
|
|
tagToString (UnknownTag t ) = t
|
|
tagToString Old = ""
|
|
|
|
instance Pretty Tag where
|
|
pPrint Recommended = text "recommended"
|
|
pPrint Latest = text "latest"
|
|
pPrint Prerelease = text "prerelease"
|
|
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
|
|
pPrint (UnknownTag t ) = text t
|
|
pPrint Old = mempty
|
|
|
|
data Architecture = A_64
|
|
| A_32
|
|
| A_PowerPC
|
|
| A_PowerPC64
|
|
| A_Sparc
|
|
| A_Sparc64
|
|
| A_ARM
|
|
| A_ARM64
|
|
deriving (Eq, GHC.Generic, Ord, Show)
|
|
|
|
archToString :: Architecture -> String
|
|
archToString A_64 = "x86_64"
|
|
archToString A_32 = "i386"
|
|
archToString A_PowerPC = "powerpc"
|
|
archToString A_PowerPC64 = "powerpc64"
|
|
archToString A_Sparc = "sparc"
|
|
archToString A_Sparc64 = "sparc64"
|
|
archToString A_ARM = "arm"
|
|
archToString A_ARM64 = "aarch64"
|
|
|
|
instance Pretty Architecture where
|
|
pPrint = text . archToString
|
|
|
|
data Platform = Linux LinuxDistro
|
|
-- ^ must exit
|
|
| Darwin
|
|
-- ^ must exit
|
|
| FreeBSD
|
|
deriving (Eq, GHC.Generic, Ord, Show)
|
|
|
|
platformToString :: Platform -> String
|
|
platformToString (Linux distro) = "linux-" ++ distroToString distro
|
|
platformToString Darwin = "darwin"
|
|
platformToString FreeBSD = "freebsd"
|
|
|
|
instance Pretty Platform where
|
|
pPrint = text . platformToString
|
|
|
|
data LinuxDistro = Debian
|
|
| Ubuntu
|
|
| Mint
|
|
| Fedora
|
|
| CentOS
|
|
| RedHat
|
|
| Alpine
|
|
| AmazonLinux
|
|
-- rolling
|
|
| Gentoo
|
|
| Exherbo
|
|
-- not known
|
|
| UnknownLinux
|
|
-- ^ must exit
|
|
deriving (Eq, GHC.Generic, Ord, Show)
|
|
|
|
distroToString :: LinuxDistro -> String
|
|
distroToString Debian = "debian"
|
|
distroToString Ubuntu = "ubuntu"
|
|
distroToString Mint= "mint"
|
|
distroToString Fedora = "fedora"
|
|
distroToString CentOS = "centos"
|
|
distroToString RedHat = "redhat"
|
|
distroToString Alpine = "alpine"
|
|
distroToString AmazonLinux = "amazon"
|
|
distroToString Gentoo = "gentoo"
|
|
distroToString Exherbo = "exherbo"
|
|
distroToString UnknownLinux = "unknown"
|
|
|
|
instance Pretty LinuxDistro where
|
|
pPrint = text . distroToString
|
|
|
|
|
|
-- | An encapsulation of a download. This can be used
|
|
-- to download, extract and install a tool.
|
|
data DownloadInfo = DownloadInfo
|
|
{ _dlUri :: URI
|
|
, _dlSubdir :: Maybe TarDir
|
|
, _dlHash :: Text
|
|
}
|
|
deriving (Eq, Ord, GHC.Generic, Show)
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Others ]--
|
|
--------------
|
|
|
|
|
|
-- | How to descend into a tar archive.
|
|
data TarDir = RealDir (Path Rel)
|
|
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
|
|
deriving (Eq, Ord, GHC.Generic, Show)
|
|
|
|
instance Pretty TarDir where
|
|
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
|
|
pPrint (RegexDir regex) = text regex
|
|
|
|
|
|
-- | Where to fetch GHCupDownloads from.
|
|
data URLSource = GHCupURL
|
|
| OwnSource URI
|
|
| OwnSpec GHCupInfo
|
|
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
|
deriving (GHC.Generic, Show)
|
|
|
|
|
|
data UserSettings = UserSettings
|
|
{ uCache :: Maybe Bool
|
|
, uNoVerify :: Maybe Bool
|
|
, uVerbose :: Maybe Bool
|
|
, uKeepDirs :: Maybe KeepDirs
|
|
, uDownloader :: Maybe Downloader
|
|
, uKeyBindings :: Maybe UserKeyBindings
|
|
, uUrlSource :: Maybe URLSource
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
defaultUserSettings :: UserSettings
|
|
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
|
|
|
data UserKeyBindings = UserKeyBindings
|
|
{ kUp :: Maybe Vty.Key
|
|
, kDown :: Maybe Vty.Key
|
|
, kQuit :: Maybe Vty.Key
|
|
, kInstall :: Maybe Vty.Key
|
|
, kUninstall :: Maybe Vty.Key
|
|
, kSet :: Maybe Vty.Key
|
|
, kChangelog :: Maybe Vty.Key
|
|
, kShowAll :: Maybe Vty.Key
|
|
, kShowAllTools :: Maybe Vty.Key
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
data KeyBindings = KeyBindings
|
|
{ bUp :: Vty.Key
|
|
, bDown :: Vty.Key
|
|
, bQuit :: Vty.Key
|
|
, bInstall :: Vty.Key
|
|
, bUninstall :: Vty.Key
|
|
, bSet :: Vty.Key
|
|
, bChangelog :: Vty.Key
|
|
, bShowAllVersions :: Vty.Key
|
|
, bShowAllTools :: Vty.Key
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
defaultKeyBindings :: KeyBindings
|
|
defaultKeyBindings = KeyBindings
|
|
{ bUp = Vty.KUp
|
|
, bDown = Vty.KDown
|
|
, bQuit = Vty.KChar 'q'
|
|
, bInstall = Vty.KChar 'i'
|
|
, bUninstall = Vty.KChar 'u'
|
|
, bSet = Vty.KChar 's'
|
|
, bChangelog = Vty.KChar 'c'
|
|
, bShowAllVersions = Vty.KChar 'a'
|
|
, bShowAllTools = Vty.KChar 't'
|
|
}
|
|
|
|
data AppState = AppState
|
|
{ settings :: Settings
|
|
, dirs :: Dirs
|
|
, keyBindings :: KeyBindings
|
|
} deriving (Show)
|
|
|
|
data Settings = Settings
|
|
{ cache :: Bool
|
|
, noVerify :: Bool
|
|
, keepDirs :: KeepDirs
|
|
, downloader :: Downloader
|
|
, verbose :: Bool
|
|
, urlSource :: URLSource
|
|
}
|
|
deriving (Show, GHC.Generic)
|
|
|
|
data Dirs = Dirs
|
|
{ baseDir :: Path Abs
|
|
, binDir :: Path Abs
|
|
, cacheDir :: Path Abs
|
|
, logsDir :: Path Abs
|
|
, confDir :: Path Abs
|
|
}
|
|
deriving Show
|
|
|
|
data KeepDirs = Always
|
|
| Errors
|
|
| Never
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data Downloader = Curl
|
|
| Wget
|
|
#if defined(INTERNAL_DOWNLOADER)
|
|
| Internal
|
|
#endif
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data DebugInfo = DebugInfo
|
|
{ diBaseDir :: Path Abs
|
|
, diBinDir :: Path Abs
|
|
, diGHCDir :: Path Abs
|
|
, diCacheDir :: Path Abs
|
|
, diArch :: Architecture
|
|
, diPlatform :: PlatformResult
|
|
}
|
|
deriving Show
|
|
|
|
|
|
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
|
| SetGHC_XY -- ^ ghc-x.y
|
|
| SetGHC_XYZ -- ^ ghc-x.y.z
|
|
deriving (Eq, Show)
|
|
|
|
|
|
data PlatformResult = PlatformResult
|
|
{ _platform :: Platform
|
|
, _distroVersion :: Maybe Versioning
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
platResToString :: PlatformResult -> String
|
|
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
|
|
= show plat <> ", " <> T.unpack (prettyV v')
|
|
platResToString PlatformResult { _platform = plat, _distroVersion = Nothing }
|
|
= show plat
|
|
|
|
instance Pretty PlatformResult where
|
|
pPrint = text . platResToString
|
|
|
|
data PlatformRequest = PlatformRequest
|
|
{ _rArch :: Architecture
|
|
, _rPlatform :: Platform
|
|
, _rVersion :: Maybe Versioning
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
pfReqToString :: PlatformRequest -> String
|
|
pfReqToString (PlatformRequest arch plat ver) =
|
|
archToString arch ++ "-" ++ platformToString plat ++ pver
|
|
where
|
|
pver = case ver of
|
|
Just v' -> "-" ++ T.unpack (prettyV v')
|
|
Nothing -> ""
|
|
|
|
instance Pretty PlatformRequest where
|
|
pPrint = text . pfReqToString
|
|
|
|
-- | A GHC identified by the target platform triple
|
|
-- and the version.
|
|
data GHCTargetVersion = GHCTargetVersion
|
|
{ _tvTarget :: Maybe Text
|
|
, _tvVersion :: Version
|
|
}
|
|
deriving (Ord, Eq, Show)
|
|
|
|
data GitBranch = GitBranch
|
|
{ ref :: String
|
|
, repo :: Maybe String
|
|
}
|
|
deriving (Ord, Eq, Show)
|
|
|
|
mkTVer :: Version -> GHCTargetVersion
|
|
mkTVer = GHCTargetVersion Nothing
|
|
|
|
tVerToText :: GHCTargetVersion -> Text
|
|
tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
|
|
tVerToText (GHCTargetVersion Nothing v') = prettyVer v'
|
|
|
|
-- | Assembles a path of the form: <target-triple>-<version>
|
|
instance Pretty GHCTargetVersion where
|
|
pPrint = text . T.unpack . tVerToText
|
|
|
|
|
|
-- | A comparator and a version.
|
|
data VersionCmp = VR_gt Versioning
|
|
| VR_gteq Versioning
|
|
| VR_lt Versioning
|
|
| VR_lteq Versioning
|
|
| VR_eq Versioning
|
|
deriving (Eq, GHC.Generic, Ord, Show)
|
|
|
|
|
|
-- | A version range. Supports && and ||, but not arbitrary
|
|
-- combinations. This is a little simplified.
|
|
data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
|
|
| OrRange (NonEmpty VersionCmp) VersionRange
|
|
deriving (Eq, GHC.Generic, Ord, Show)
|
|
|
|
|
|
instance Pretty Versioning where
|
|
pPrint = text . T.unpack . prettyV
|
|
|
|
instance Pretty Version where
|
|
pPrint = text . T.unpack . prettyVer
|