{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} {-| Module : GHCup.Types Description : GHCup types Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} module GHCup.Types ( module GHCup.Types #if defined(BRICK) , Key(..) #endif ) where import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Time.Calendar ( Day ) import Data.Text ( Text ) import Data.Versions import GHC.IO.Exception ( ExitCode ) import Optics ( makeLenses ) import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import URI.ByteString #if defined(BRICK) import Graphics.Vty ( Key(..) ) #endif import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified GHC.Generics as GHC import qualified Data.List.NonEmpty as NE import Data.Foldable (foldMap) #if !defined(BRICK) data Key = KEsc | KChar Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter | KFun Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu deriving (Eq,Show,Read,Ord,GHC.Generic) #endif -------------------- --[ GHCInfo Tree ]-- -------------------- data GHCupInfo = GHCupInfo { _toolRequirements :: ToolRequirements , _ghcupDownloads :: GHCupDownloads , _globalTools :: Map GlobalTool DownloadInfo } deriving (Show, GHC.Generic, Eq) instance NFData GHCupInfo ------------------------- --[ 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, Eq) instance NFData Requirements --------------------- --[ Download Tree ]-- --------------------- -- | Description of all binary and source downloads. This is a tree -- of nested maps. type GHCupDownloads = Map Tool ToolVersionSpec type ToolVersionSpec = Map GHCTargetVersion 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) instance Pretty Tool where pPrint GHC = text "ghc" pPrint Cabal = text "cabal" pPrint GHCup = text "ghcup" pPrint HLS = text "hls" pPrint Stack = text "stack" instance NFData Tool data GlobalTool = ShimGen deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded) instance NFData GlobalTool instance Pretty GlobalTool where pPrint ShimGen = text "shimgen" -- | All necessary information of a tool version, including -- source download and per-architecture downloads. data VersionInfo = VersionInfo { _viTags :: [Tag] -- ^ version specific tag , _viReleaseDay :: Maybe Day , _viChangeLog :: Maybe URI , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball , _viTestDL :: Maybe DownloadInfo -- ^ test 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) instance NFData VersionInfo -- | A tag. These are currently attached to a version of a tool. data Tag = Latest | Recommended | Prerelease | LatestPrerelease | Nightly | LatestNightly | Base PVP | Old -- ^ old versions are hidden by default in TUI | UnknownTag String -- ^ used for upwardscompat deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance instance NFData Tag tagToString :: Tag -> String tagToString Recommended = "recommended" tagToString Latest = "latest" tagToString Prerelease = "prerelease" tagToString Nightly = "nightly" tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') tagToString (UnknownTag t ) = t tagToString LatestPrerelease = "latest-prerelease" tagToString LatestNightly = "latest-nightly" tagToString Old = "" instance Pretty Tag where pPrint Recommended = text "recommended" pPrint Latest = text "latest" pPrint Prerelease = text "prerelease" pPrint Nightly = text "nightly" pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp'')) pPrint (UnknownTag t ) = text t pPrint LatestPrerelease = text "latest-prerelease" pPrint LatestNightly = text "latest-prerelease" 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) instance NFData Architecture 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 | Windows -- ^ must exit deriving (Eq, GHC.Generic, Ord, Show) instance NFData Platform platformToString :: Platform -> String platformToString (Linux distro) = "linux-" ++ distroToString distro platformToString Darwin = "darwin" platformToString FreeBSD = "freebsd" platformToString Windows = "windows" 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) instance NFData LinuxDistro 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 , _dlCSize :: Maybe Integer , _dlOutput :: Maybe FilePath } deriving (Eq, Ord, GHC.Generic, Show) instance NFData DownloadInfo -------------- --[ Others ]-- -------------- data DownloadMirror = DownloadMirror { authority :: Authority , pathPrefix :: Maybe Text } deriving (Eq, Ord, GHC.Generic, Show) instance NFData DownloadMirror newtype DownloadMirrors = DM (Map Text DownloadMirror) deriving (Eq, Ord, GHC.Generic, Show) instance NFData DownloadMirrors instance NFData UserInfo instance NFData Host instance NFData Port instance NFData Authority -- | How to descend into a tar archive. data TarDir = RealDir FilePath | RegexDir String -- ^ will be compiled to regex, the first match will "win" deriving (Eq, Ord, GHC.Generic, Show) instance NFData TarDir instance Pretty TarDir where pPrint (RealDir path) = text path pPrint (RegexDir regex) = text regex -- | Where to fetch GHCupDownloads from. data URLSource = GHCupURL | OwnSource [Either GHCupInfo URI] -- ^ complete source list | OwnSpec GHCupInfo | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL deriving (GHC.Generic, Show) instance NFData URLSource instance NFData (URIRef Absolute) where rnf (URI !_ !_ !_ !_ !_) = () data MetaMode = Strict | Lax deriving (Show, Read, Eq, GHC.Generic) instance NFData MetaMode data UserSettings = UserSettings { uCache :: Maybe Bool , uMetaCache :: Maybe Integer , uMetaMode :: Maybe MetaMode , uNoVerify :: Maybe Bool , uVerbose :: Maybe Bool , uKeepDirs :: Maybe KeepDirs , uDownloader :: Maybe Downloader , uKeyBindings :: Maybe UserKeyBindings , uUrlSource :: Maybe URLSource , uNoNetwork :: Maybe Bool , uGPGSetting :: Maybe GPGSetting , uPlatformOverride :: Maybe PlatformRequest , uMirrors :: Maybe DownloadMirrors } deriving (Show, GHC.Generic) defaultUserSettings :: UserSettings defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = UserSettings { uCache = Just cache , uMetaCache = Just metaCache , uMetaMode = Just metaMode , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs , uDownloader = Just downloader , uNoNetwork = Just noNetwork , uKeyBindings = Nothing , uUrlSource = Just urlSource , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors } fromSettings Settings{..} (Just KeyBindings{..}) = let ukb = UserKeyBindings { kUp = Just bUp , kDown = Just bDown , kQuit = Just bQuit , kInstall = Just bInstall , kUninstall = Just bUninstall , kSet = Just bSet , kChangelog = Just bChangelog , kShowAll = Just bShowAllVersions , kShowAllTools = Just bShowAllTools } in UserSettings { uCache = Just cache , uMetaCache = Just metaCache , uMetaMode = Just metaMode , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs , uDownloader = Just downloader , uNoNetwork = Just noNetwork , uKeyBindings = Just ukb , uUrlSource = Just urlSource , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors } data UserKeyBindings = UserKeyBindings { kUp :: Maybe Key , kDown :: Maybe Key , kQuit :: Maybe Key , kInstall :: Maybe Key , kUninstall :: Maybe Key , kSet :: Maybe Key , kChangelog :: Maybe Key , kShowAll :: Maybe Key , kShowAllTools :: Maybe Key } deriving (Show, GHC.Generic) data KeyBindings = KeyBindings { bUp :: Key , bDown :: Key , bQuit :: Key , bInstall :: Key , bUninstall :: Key , bSet :: Key , bChangelog :: Key , bShowAllVersions :: Key , bShowAllTools :: Key } deriving (Show, GHC.Generic) instance NFData KeyBindings #if defined(IS_WINDOWS) || !defined(BRICK) instance NFData Key #endif defaultKeyBindings :: KeyBindings defaultKeyBindings = KeyBindings { bUp = KUp , bDown = KDown , bQuit = KChar 'q' , bInstall = KChar 'i' , bUninstall = KChar 'u' , bSet = KChar 's' , bChangelog = KChar 'c' , bShowAllVersions = KChar 'a' , bShowAllTools = KChar 't' } data AppState = AppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings , ghcupInfo :: GHCupInfo , pfreq :: PlatformRequest , loggerConfig :: LoggerConfig } deriving (Show, GHC.Generic) instance NFData AppState fromAppState :: AppState -> LeanAppState fromAppState AppState {..} = LeanAppState {..} data LeanAppState = LeanAppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings , loggerConfig :: LoggerConfig } deriving (Show, GHC.Generic) instance NFData LeanAppState data Settings = Settings { cache :: Bool , metaCache :: Integer , metaMode :: MetaMode , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader , verbose :: Bool , urlSource :: URLSource , noNetwork :: Bool , gpgSetting :: GPGSetting , noColor :: Bool -- this also exists in LoggerConfig , platformOverride :: Maybe PlatformRequest , mirrors :: DownloadMirrors } deriving (Show, GHC.Generic) defaultMetaCache :: Integer defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) instance NFData Settings data Dirs = Dirs { baseDir :: GHCupPath , binDir :: FilePath , cacheDir :: GHCupPath , logsDir :: GHCupPath , confDir :: GHCupPath , dbDir :: GHCupPath , recycleDir :: GHCupPath -- mainly used on windows , tmpDir :: GHCupPath } deriving (Show, GHC.Generic) instance NFData Dirs data KeepDirs = Always | Errors | Never deriving (Eq, Show, Ord, GHC.Generic) instance NFData KeepDirs data Downloader = Curl | Wget #if defined(INTERNAL_DOWNLOADER) | Internal #endif deriving (Eq, Show, Ord, GHC.Generic) instance NFData Downloader data GPGSetting = GPGStrict | GPGLax | GPGNone deriving (Eq, Show, Ord, GHC.Generic) instance NFData GPGSetting data DebugInfo = DebugInfo { diBaseDir :: FilePath , diBinDir :: FilePath , diGHCDir :: FilePath , diCacheDir :: FilePath , 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 SetHLS = SetHLSOnly -- ^ unversioned 'hls' | SetHLS_XYZ -- ^ haskell-language-server-a.b.c~x.y.z, where a.b.c is GHC version and x.y.z is HLS version deriving (Eq, Show) data PlatformResult = PlatformResult { _platform :: Platform , _distroVersion :: Maybe Versioning } deriving (Eq, Show, GHC.Generic) instance NFData PlatformResult 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, GHC.Generic) instance NFData PlatformRequest 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, GHC.Generic) instance NFData GHCTargetVersion 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: - 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) instance NFData VersionCmp -- | 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 NFData VersionRange instance Pretty VersionCmp where pPrint (VR_gt v) = text "> " <> pPrint v pPrint (VR_gteq v) = text ">= " <> pPrint v pPrint (VR_lt v) = text "< " <> pPrint v pPrint (VR_lteq v) = text "<= " <> pPrint v pPrint (VR_eq v) = text "= " <> pPrint v instance Pretty VersionRange where pPrint (SimpleRange xs) = foldl1 (\x y -> x <> text " && " <> y) $ NE.map pPrint xs pPrint (OrRange xs vr) = foldMap pPrint xs <> " || " <> pPrint vr instance Pretty Versioning where pPrint = text . T.unpack . prettyV instance Pretty Version where pPrint = text . T.unpack . prettyVer instance Show (a -> b) where show _ = "" instance Show (IO ()) where show _ = "" data LogLevel = Warn | Info | Debug | Error deriving (Eq, Ord, Show) data LoggerConfig = LoggerConfig { lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter , consoleOutter :: T.Text -> IO () -- ^ how to write the console output , fileOutter :: T.Text -> IO () -- ^ how to write the file output , fancyColors :: Bool } deriving Show instance NFData LoggerConfig where rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors) data ProcessError = NonZeroExit Int FilePath [String] | PTerminated FilePath [String] | PStopped FilePath [String] | NoSuchPid FilePath [String] deriving Show data CapturedProcess = CapturedProcess { _exitCode :: ExitCode , _stdOut :: BL.ByteString , _stdErr :: BL.ByteString } deriving (Eq, Show) makeLenses ''CapturedProcess data InstallDir = IsolateDir FilePath | GHCupInternal deriving (Eq, Show) data InstallDirResolved = IsolateDirResolved FilePath | GHCupDir GHCupPath | GHCupBinDir FilePath deriving (Eq, Show) fromInstallDir :: InstallDirResolved -> FilePath fromInstallDir (IsolateDirResolved fp) = fp fromInstallDir (GHCupDir fp) = fromGHCupPath fp fromInstallDir (GHCupBinDir fp) = fp isSafeDir :: InstallDirResolved -> Bool isSafeDir (IsolateDirResolved _) = False isSafeDir (GHCupDir _) = True isSafeDir (GHCupBinDir _) = False type PromptQuestion = Text data PromptResponse = PromptYes | PromptNo deriving (Show, Eq) data ToolVersion = GHCVersion GHCTargetVersion | ToolVersion Version | ToolTag Tag | ToolDay Day deriving (Eq, Show) instance Pretty ToolVersion where pPrint (GHCVersion v) = pPrint v pPrint (ToolVersion v) = pPrint v pPrint (ToolTag t) = pPrint t pPrint (ToolDay d) = text (show d) data BuildSystem = Hadrian | Make deriving (Show, Eq)