ghcup-hs/lib/GHCup/Types.hs

364 lines
9.4 KiB
Haskell
Raw Normal View History

2020-04-25 10:06:41 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Types
Description : GHCup types
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
-}
2020-01-11 20:15:05 +00:00
module GHCup.Types where
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
2020-01-11 20:15:05 +00:00
import Data.Text ( Text )
import Data.Versions
import HPath
import URI.ByteString
import qualified Data.Text as T
2020-01-11 20:15:05 +00:00
import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
2020-01-11 20:15:05 +00:00
2020-04-10 15:36:27 +00:00
--------------------
--[ 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
2020-04-10 15:36:27 +00:00
data Requirements = Requirements
{ _distroPKGs :: [Text]
, _notes :: Text
}
deriving (Show, GHC.Generic)
2020-01-11 20:15:05 +00:00
---------------------
--[ 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
2020-01-11 20:15:05 +00:00
-- | An installable tool.
data Tool = GHC
| Cabal
| GHCup
| HLS
2021-01-02 06:58:08 +00:00
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
2020-01-11 20:15:05 +00:00
-- | 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
2020-01-11 20:15:05 +00:00
}
2020-09-13 18:46:34 +00:00
deriving (Eq, GHC.Generic, Show)
2020-01-11 20:15:05 +00:00
-- | A tag. These are currently attached to a version of a tool.
data Tag = Latest
| Recommended
2020-07-28 18:55:00 +00:00
| Prerelease
2020-04-22 00:33:35 +00:00
| Base PVP
| Old -- ^ old version are hidden by default in TUI
2020-04-22 00:33:35 +00:00
| UnknownTag String -- ^ used for upwardscompat
2020-09-13 18:46:34 +00:00
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
2020-01-11 20:15:05 +00:00
data Architecture = A_64
| A_32
2020-06-27 17:00:13 +00:00
| A_PowerPC
| A_PowerPC64
| A_Sparc
| A_Sparc64
| A_ARM
| A_ARM64
2020-01-11 20:15:05 +00:00
deriving (Eq, GHC.Generic, Ord, Show)
prettyArch :: Architecture -> String
prettyArch A_64 = "x86_64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "powerpc"
prettyArch A_PowerPC64 = "powerpc64"
prettyArch A_Sparc = "sparc"
prettyArch A_Sparc64 = "sparc64"
prettyArch A_ARM = "arm"
prettyArch A_ARM64 = "aarch64"
2020-01-11 20:15:05 +00:00
data Platform = Linux LinuxDistro
-- ^ must exit
| Darwin
-- ^ must exit
| FreeBSD
deriving (Eq, GHC.Generic, Ord, Show)
prettyPlatfrom :: Platform -> String
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
prettyPlatfrom Darwin = "darwin"
prettyPlatfrom FreeBSD = "freebsd"
2020-01-11 20:15:05 +00:00
data LinuxDistro = Debian
| Ubuntu
| Mint
| Fedora
| CentOS
| RedHat
| Alpine
| AmazonLinux
-- rolling
| Gentoo
| Exherbo
-- not known
| UnknownLinux
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
prettyDistro :: LinuxDistro -> String
prettyDistro Debian = "debian"
prettyDistro Ubuntu = "ubuntu"
prettyDistro Mint= "mint"
prettyDistro Fedora = "fedora"
prettyDistro CentOS = "centos"
prettyDistro RedHat = "redhat"
prettyDistro Alpine = "alpine"
prettyDistro AmazonLinux = "amazon"
prettyDistro Gentoo = "gentoo"
prettyDistro Exherbo = "exherbo"
prettyDistro UnknownLinux = "unknown"
2020-01-11 20:15:05 +00:00
-- | An encapsulation of a download. This can be used
-- to download, extract and install a tool.
data DownloadInfo = DownloadInfo
{ _dlUri :: URI
2020-08-06 11:28:20 +00:00
, _dlSubdir :: Maybe TarDir
2020-01-11 20:15:05 +00:00
, _dlHash :: Text
}
deriving (Eq, Ord, GHC.Generic, Show)
2020-01-11 20:15:05 +00:00
--------------
--[ Others ]--
--------------
2020-08-06 11:28:20 +00:00
-- | 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)
2020-08-06 11:28:20 +00:00
2020-01-11 20:15:05 +00:00
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
2020-04-10 15:36:27 +00:00
| OwnSpec GHCupInfo
2020-10-25 13:17:17 +00:00
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
2020-09-13 18:46:34 +00:00
deriving (GHC.Generic, Show)
2020-01-11 20:15:05 +00:00
data UserSettings = UserSettings
{ uCache :: Maybe Bool
, uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs
, uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings
2020-10-25 13:17:17 +00:00
, uUrlSource :: Maybe URLSource
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
2020-10-25 13:17:17 +00:00
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
}
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
, bShowAll :: 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'
, bShowAll = Vty.KChar 'a'
}
2020-10-23 23:06:53 +00:00
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
2020-10-23 23:06:53 +00:00
} deriving (Show)
2020-01-11 20:15:05 +00:00
data Settings = Settings
2020-10-23 23:06:53 +00:00
{ cache :: Bool
2020-04-29 17:12:58 +00:00
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
2020-07-13 09:52:34 +00:00
, verbose :: Bool
2020-10-25 13:17:17 +00:00
, urlSource :: URLSource
2020-01-11 20:15:05 +00:00
}
deriving (Show, GHC.Generic)
2020-01-11 20:15:05 +00:00
2020-07-31 18:10:40 +00:00
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
, confDir :: Path Abs
2020-07-31 18:10:40 +00:00
}
deriving Show
2020-01-11 20:15:05 +00:00
2020-04-22 16:12:40 +00:00
data KeepDirs = Always
| Errors
| Never
deriving (Eq, Show, Ord)
2020-04-29 17:12:58 +00:00
data Downloader = Curl
| Wget
#if defined(INTERNAL_DOWNLOADER)
| Internal
#endif
deriving (Eq, Show, Ord)
2020-04-22 16:12:40 +00:00
2020-01-11 20:15:05 +00:00
data DebugInfo = DebugInfo
2020-03-17 17:39:01 +00:00
{ diBaseDir :: Path Abs
, diBinDir :: Path Abs
, diGHCDir :: Path Abs
, diCacheDir :: Path Abs
, diArch :: Architecture
, diPlatform :: PlatformResult
2020-01-11 20:15:05 +00:00
}
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)
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> T.unpack (prettyV v')
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
2020-01-11 20:15:05 +00:00
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
, _rVersion :: Maybe Versioning
}
deriving (Eq, Show)
2020-04-25 10:06:41 +00:00
prettyPfReq :: PlatformRequest -> String
prettyPfReq (PlatformRequest arch plat ver) =
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v')
Nothing -> ""
2020-04-25 10:06:41 +00:00
-- | A GHC identified by the target platform triple
-- and the version.
data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text
, _tvVersion :: Version
}
deriving (Ord, Eq, Show)
mkTVer :: Version -> GHCTargetVersion
mkTVer = GHCTargetVersion Nothing
-- | Assembles a path of the form: <target-triple>-<version>
prettyTVer :: GHCTargetVersion -> Text
prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
prettyTVer (GHCTargetVersion Nothing v') = prettyVer v'
-- | 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)