Refactor app Main

.gitignore

@@ -13,3 +13,5 @@ TAGS
 /tmp/
 .entangled
 release/
+releases/
+site/

.gitlab/script/hlint.sh

@@ -15,5 +15,5 @@ git describe
 ecabal update
 ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
 
-hlint -r lib/ test/ 
+hlint -r app/ lib/ test/ 
 

app/ghcup-gen/Main.hs

@@ -1,10 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 

app/ghcup-gen/Validate.hs

@@ -91,23 +91,23 @@ validate dls _ = do
   checkHasRequiredPlatforms t v tags arch pspecs = do
     let v' = prettyVer v
         arch' = prettyShow arch
-    when (notElem (Linux UnknownLinux) pspecs) $ do
+    when (Linux UnknownLinux `notElem` pspecs) $ do
       lift $ logError $
         "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((notElem Darwin pspecs) && arch == A_64) $ do
+    when ((Darwin `notElem` pspecs) && arch == A_64) $ do
       lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
+    when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
       "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
-    when (notElem Windows pspecs && arch == A_64) $ do
+    when (Windows `notElem` pspecs && arch == A_64) $ do
       lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
 
     -- alpine needs to be set explicitly, because
     -- we cannot assume that "Linux UnknownLinux" runs on Alpine
     -- (although it could be static)
-    when (notElem (Linux Alpine) pspecs) $
+    when (Linux Alpine `notElem` pspecs) $
       case t of
         GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
         Cabal | v > [vver|2.4.1.0|]
@@ -117,7 +117,7 @@ validate dls _ = do
         _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
 
   checkUniqueTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -155,8 +155,8 @@ validate dls _ = do
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
-    forM_ [Latest, Recommended] $ \t -> case elem t allTags of
+    forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
       False -> do
         lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
         addError
@@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
   let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
   let gdlis = nubOrd $ gt ^.. each
   let allDls = either (const gdlis) (const dlis) etool
-  when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
+  when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
   forM_ allDls (downloadAll ref)
 
   -- exit
@@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
             when (basePath /= prel) $ do
               logError $
                 "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
+              runReaderT addError ref
           Just (RegexDir regexString) -> do
             logInfo $
               "verifying subdir (regex): " <> T.pack regexString
@@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                   compIgnoreCase
                   execBlank
                   regexString
-            when (not (match regex basePath)) $ do
+            unless (match regex basePath) $ do
               logError $
                 "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
+              runReaderT addError ref
           Nothing -> pure ()
       VRight Nothing -> pure ()
       VLeft  e -> do
         logError $
           "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
-        (flip runReaderT ref addError)
+        runReaderT addError ref

app/ghcup/BrickMain.hs

@@ -2,10 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE ViewPatterns      #-}
 {-# LANGUAGE RankNTypes        #-}
 
 module BrickMain where
@@ -368,10 +365,7 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
 
 
 selectLatest :: Vector ListResult -> Int
-selectLatest v =
+selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
-  case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
-    Just ix -> ix
-    Nothing -> 0
 
 
 -- | Replace the @appState@ or construct it based on a filter function
@@ -398,14 +392,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
 filterVisible v t e | lInstalled e = True
                     | v
                     , not t
-                    , not (elem (lTool e) hiddenTools) = True
+                    , lTool e `notElem` hiddenTools = True
                     | not v
                     , t
-                    , not (elem Old (lTag e)) = True
+                    , Old `notElem` lTag e = True
                     | v
                     , t = True
-                    | otherwise = not (elem Old (lTag e)) &&
+                    | otherwise = (Old `notElem` lTag e) &&
-                                  not (elem (lTool e) hiddenTools)
+                                  (lTool e `notElem` hiddenTools)
 
 
 install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
@@ -507,7 +501,7 @@ del' _ (_, ListResult {..}) = do
     )
     >>= \case
           VRight vi -> do
-            forM_ (join $ fmap _viPostRemove vi) $ \msg ->
+            forM_ (_viPostRemove =<< vi) $ \msg ->
               logInfo msg
             pure $ Right ()
           VLeft  e -> pure $ Left (prettyShow e)
@@ -594,8 +588,7 @@ getGHCupInfo = do
   r <-
     flip runReaderT settings
     . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
-    $ liftE
+    $ liftE getDownloadsF
-    $ getDownloadsF
 
   case r of
     VRight a -> pure $ Right a

app/ghcup/GHCup/OptParse.hs

@@ -0,0 +1,303 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module GHCup.OptParse (
+    module GHCup.OptParse.Common
+  , module GHCup.OptParse.Install
+  , module GHCup.OptParse.Set
+  , module GHCup.OptParse.UnSet
+  , module GHCup.OptParse.Rm
+  , module GHCup.OptParse.Compile
+  , module GHCup.OptParse.Config
+  , module GHCup.OptParse.Whereis
+  , module GHCup.OptParse.List
+  , module GHCup.OptParse.Upgrade
+  , module GHCup.OptParse.ChangeLog
+  , module GHCup.OptParse.Prefetch
+  , module GHCup.OptParse.GC
+  , module GHCup.OptParse.DInfo
+  , module GHCup.OptParse.Nuke
+  , module GHCup.OptParse.ToolRequirements
+  , module GHCup.OptParse
+) where
+
+
+import           GHCup.OptParse.Common
+import           GHCup.OptParse.Install
+import           GHCup.OptParse.Set
+import           GHCup.OptParse.UnSet
+import           GHCup.OptParse.Rm
+import           GHCup.OptParse.Compile
+import           GHCup.OptParse.Config
+import           GHCup.OptParse.Whereis
+import           GHCup.OptParse.List
+import           GHCup.OptParse.Upgrade
+import           GHCup.OptParse.ChangeLog
+import           GHCup.OptParse.Prefetch
+import           GHCup.OptParse.GC
+import           GHCup.OptParse.DInfo
+import           GHCup.OptParse.ToolRequirements
+import           GHCup.OptParse.Nuke
+
+import           GHCup.Types
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Data.Bifunctor
+import           Data.Either
+import           Data.Functor
+import           Data.Maybe
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           URI.ByteString
+
+import qualified Data.ByteString.UTF8          as UTF8
+
+
+
+data Options = Options
+  {
+  -- global options
+    optVerbose     :: Maybe Bool
+  , optCache       :: Maybe Bool
+  , optUrlSource   :: Maybe URI
+  , optNoVerify    :: Maybe Bool
+  , optKeepDirs    :: Maybe KeepDirs
+  , optsDownloader :: Maybe Downloader
+  , optNoNetwork   :: Maybe Bool
+  , optGpg         :: Maybe GPGSetting
+  -- commands
+  , optCommand     :: Command
+  }
+
+data Command
+  = Install (Either InstallCommand InstallOptions)
+  | InstallCabalLegacy InstallOptions
+  | Set (Either SetCommand SetOptions)
+  | UnSet UnsetCommand
+  | List ListOptions
+  | Rm (Either RmCommand RmOptions)
+  | DInfo
+  | Compile CompileCommand
+  | Config ConfigCommand
+  | Whereis WhereisOptions WhereisCommand
+  | Upgrade UpgradeOpts Bool
+  | ToolRequirements
+  | ChangeLog ChangeLogOptions
+  | Nuke
+#if defined(BRICK)
+  | Interactive
+#endif
+  | Prefetch PrefetchCommand
+  | GC GCOptions
+
+
+
+opts :: Parser Options
+opts =
+  Options
+    <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
+    <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
+    <*> optional
+          (option
+            (eitherReader parseUri)
+            (  short 's'
+            <> long "url-source"
+            <> metavar "URL"
+            <> help "Alternative ghcup download info url"
+            <> internal
+            )
+          )
+    <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
+    <*> optional (option
+          (eitherReader keepOnParser)
+          (  long "keep"
+          <> metavar "<always|errors|never>"
+          <> help
+               "Keep build directories? (default: errors)"
+          <> hidden
+          ))
+    <*> optional (option
+          (eitherReader downloaderParser)
+          (  long "downloader"
+#if defined(INTERNAL_DOWNLOADER)
+          <> metavar "<internal|curl|wget>"
+          <> help
+          "Downloader to use (default: internal)"
+#else
+          <> metavar "<curl|wget>"
+          <> help
+          "Downloader to use (default: curl)"
+#endif
+          <> hidden
+          ))
+    <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
+    <*> optional (option
+          (eitherReader gpgParser)
+          (  long "gpg"
+          <> metavar "<strict|lax|none>"
+          <> help
+          "GPG verification (default: none)"
+          ))
+    <*> com
+ where
+  parseUri s' =
+    first show $ parseURI strictURIParserOptions (UTF8.fromString s')
+
+
+com :: Parser Command
+com =
+  subparser
+#if defined(BRICK)
+      (  command
+          "tui"
+          (   (\_ -> Interactive)
+          <$> info
+                helper
+                (  progDesc "Start the interactive GHCup UI"
+                )
+          )
+      <>  command
+#else
+      (  command
+#endif
+          "install"
+          (   Install
+          <$> info
+                (installParser <**> helper)
+                (  progDesc "Install or update GHC/cabal/HLS/stack"
+                <> footerDoc (Just $ text installToolFooter)
+                )
+          )
+      <> command
+           "set"
+           (info
+             (Set <$> setParser <**> helper)
+             (  progDesc "Set currently active GHC/cabal version"
+             <> footerDoc (Just $ text setFooter)
+             )
+           )
+      <> command
+           "unset"
+           (info
+             (UnSet <$> unsetParser <**> helper)
+             (  progDesc "Unset currently active GHC/cabal version"
+             <> footerDoc (Just $ text unsetFooter)
+             )
+           )
+      <> command
+           "rm"
+           (info
+             (Rm <$> rmParser <**> helper)
+             (  progDesc "Remove a GHC/cabal/HLS/stack version"
+             <> footerDoc (Just $ text rmFooter)
+             )
+           )
+
+      <> command
+           "list"
+           (info (List <$> listOpts <**> helper)
+                 (progDesc "Show available GHCs and other tools")
+           )
+      <> command
+           "upgrade"
+           (info
+             (    (Upgrade <$> upgradeOptsP <*> switch
+                    (short 'f' <> long "force" <> help "Force update")
+                  )
+             <**> helper
+             )
+             (progDesc "Upgrade ghcup")
+           )
+      <> command
+           "compile"
+           (   Compile
+           <$> info (compileP <**> helper)
+                    (progDesc "Compile a tool from source")
+           )
+      <> command
+           "whereis"
+            (info
+             (   (Whereis
+                     <$> (WhereisOptions <$> switch (short 'd' <> long "directory" <> help "return directory of the binary instead of the binary location"))
+                     <*> whereisP
+                 ) <**> helper
+             )
+             (progDesc "Find a tools location"
+             <> footerDoc ( Just $ text whereisFooter ))
+           )
+      <> command
+           "prefetch"
+            (info
+             (   (Prefetch
+                     <$> prefetchP
+                 ) <**> helper
+             )
+             (progDesc "Prefetch assets"
+             <> footerDoc ( Just $ text prefetchFooter ))
+           )
+      <> command
+           "gc"
+            (info
+             (   (GC
+                     <$> gcP
+                 ) <**> helper
+             )
+             (progDesc "Garbage collection"
+             <> footerDoc ( Just $ text gcFooter ))
+           )
+      <> commandGroup "Main commands:"
+      )
+    <|> subparser
+          (  command
+              "debug-info"
+              ((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
+          <> command
+               "tool-requirements"
+               (   (\_ -> ToolRequirements)
+               <$> info helper
+                        (progDesc "Show the requirements for ghc/cabal")
+               )
+          <> command
+               "changelog"
+               (info
+                  (fmap ChangeLog changelogP <**> helper)
+                  (  progDesc "Find/show changelog"
+                  <> footerDoc (Just $ text changeLogFooter)
+                  )
+               )
+          <> command
+               "config"
+               (   Config
+               <$> info (configP <**> helper)
+                        (progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
+               )
+          <> commandGroup "Other commands:"
+          <> hidden
+          )
+    <|> subparser
+          (  command
+              "install-cabal"
+              (info
+                 ((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
+                 (  progDesc "Install or update cabal"
+                 <> footerDoc (Just $ text installCabalFooter)
+                 )
+              )
+          <> internal
+          )
+     <|> subparser
+          (command
+              "nuke"
+               (info (pure Nuke <**> helper)
+                     (progDesc "Completely remove ghcup from your system"))
+           <> commandGroup "Nuclear Commands:"
+           <> hidden
+          )

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.ChangeLog where
+
+
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
+import GHCup.Utils
+import Data.Versions
+import URI.ByteString (serializeURIRef')
+import GHCup.Utils.Prelude
+import GHCup.Utils.File (exec)
+import Data.Char (toLower)
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data ChangeLogOptions = ChangeLogOptions
+  { clOpen    :: Bool
+  , clTool    :: Maybe Tool
+  , clToolVer :: Maybe ToolVersion
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+changelogP :: Parser ChangeLogOptions
+changelogP =
+  (\x y -> ChangeLogOptions x y)
+    <$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
+    <*> optional
+          (option
+            (eitherReader
+              (\s' -> case fmap toLower s' of
+                "ghc"   -> Right GHC
+                "cabal" -> Right Cabal
+                "ghcup" -> Right GHCup
+                "stack" -> Right Stack
+                e       -> Left e
+              )
+            )
+            (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
+              "Open changelog for given tool (default: ghc)"
+            )
+          )
+    <*> optional (toolVersionArgument Nothing Nothing)
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+changeLogFooter :: String
+changeLogFooter = [s|Discussion:
+  By default returns the URI of the ChangeLog of the latest GHC release.
+  Pass '-o' to automatically open via xdg-open.|]
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+changelog :: ( Monad m
+             , MonadMask m
+             , MonadUnliftIO m
+             , MonadFail m
+             )
+          => ChangeLogOptions
+          -> (forall a . ReaderT AppState m a -> m a)
+          -> (ReaderT LeanAppState m () -> m ())
+          -> m ExitCode
+changelog ChangeLogOptions{..} runAppState runLogger = do
+  GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
+  let tool = fromMaybe GHC clTool
+      ver' = maybe
+        (Right Latest)
+        (\case
+          ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion
+          ToolTag     t  -> Right t
+        )
+        clToolVer
+      muri = getChangeLog dls tool ver'
+  case muri of
+    Nothing -> do
+      runLogger
+        (logWarn $
+          "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
+        )
+      pure ExitSuccess
+    Just uri -> do
+      pfreq <- runAppState getPlatformReq
+      let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
+          cmd = case _rPlatform pfreq of
+                  Darwin  -> "open"
+                  Linux _ -> "xdg-open"
+                  FreeBSD -> "xdg-open"
+                  Windows -> "start"
+
+      if clOpen
+        then do
+          runAppState $
+            exec cmd
+                 [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
+                 Nothing
+                 Nothing
+              >>= \case
+                    Right _ -> pure ExitSuccess
+                    Left  e -> logError (T.pack $ prettyShow e)
+                      >> pure (ExitFailure 13)
+        else liftIO $ putStrLn uri' >> pure ExitSuccess

app/ghcup/GHCup/OptParse/Common.hs

@@ -0,0 +1,513 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module GHCup.OptParse.Common where
+
+
+import           GHCup
+import           GHCup.Download
+import           GHCup.Errors
+import           GHCup.Platform
+import           GHCup.Types
+import           GHCup.Types.Optics
+import           GHCup.Utils
+import           GHCup.Utils.Logger
+import           GHCup.Utils.MegaParsec
+import           GHCup.Utils.Prelude
+
+import           Control.Exception.Safe
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Data.Bifunctor
+import           Data.Char
+import           Data.Either
+import           Data.Functor
+import           Data.List                      ( nub, sort, sortBy )
+import           Data.Maybe
+import           Data.Text                      ( Text )
+import           Data.Versions           hiding ( str )
+import           Data.Void
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           Safe
+import           System.FilePath
+import           URI.ByteString
+
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.Map.Strict               as M
+import qualified Data.Text                     as T
+import qualified Text.Megaparsec               as MP
+import GHCup.Version
+
+
+    -------------
+    --[ Types ]--
+    -------------
+
+data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
+                 | ToolTag Tag
+
+-- a superset of ToolVersion
+data SetToolVersion = SetToolVersion GHCTargetVersion
+                    | SetToolTag Tag
+                    | SetRecommended
+                    | SetNext
+
+prettyToolVer :: ToolVersion -> String
+prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
+prettyToolVer (ToolTag t) = show t
+
+toSetToolVer :: Maybe ToolVersion -> SetToolVersion
+toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'
+toSetToolVer (Just (ToolTag t')) = SetToolTag t'
+toSetToolVer Nothing = SetRecommended
+
+
+
+
+    --------------
+    --[ Parser ]--
+    --------------
+
+
+-- | same as toolVersionParser, except as an argument.
+toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
+toolVersionArgument criteria tool =
+  argument (eitherReader toolVersionEither)
+    (metavar (mv tool)
+    <> completer (tagCompleter (fromMaybe GHC tool) [])
+    <> foldMap (completer . versionCompleter criteria) tool)
+ where
+  mv (Just GHC) = "GHC_VERSION|TAG"
+  mv (Just HLS) = "HLS_VERSION|TAG"
+  mv _          = "VERSION|TAG"
+
+
+versionParser :: Parser GHCTargetVersion
+versionParser = option
+  (eitherReader tVersionEither)
+  (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
+  )
+
+versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version
+versionParser' criteria tool = argument
+  (eitherReader (first show . version . T.pack))
+  (metavar "VERSION"  <> foldMap (completer . versionCompleter criteria) tool)
+
+versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
+versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
+
+
+-- https://github.com/pcapriotti/optparse-applicative/issues/148
+
+-- | A switch that can be enabled using --foo and disabled using --no-foo.
+--
+-- The option modifier is applied to only the option that is *not* enabled
+-- by default. For example:
+--
+-- > invertableSwitch "recursive" True (help "do not recurse into directories")
+--
+-- This example makes --recursive enabled by default, so
+-- the help is shown only for --no-recursive.
+invertableSwitch
+    :: String              -- ^ long option
+    -> Char                -- ^ short option for the non-default option
+    -> Bool                -- ^ is switch enabled by default?
+    -> Mod FlagFields Bool -- ^ option modifier
+    -> Parser (Maybe Bool)
+invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
+    (if defv then mempty else optmod)
+    (if defv then optmod else mempty)
+
+-- | Allows providing option modifiers for both --foo and --no-foo.
+invertableSwitch'
+    :: String              -- ^ long option (eg "foo")
+    -> Char                -- ^ short option for the non-default option
+    -> Bool                -- ^ is switch enabled by default?
+    -> Mod FlagFields Bool -- ^ option modifier for --foo
+    -> Mod FlagFields Bool -- ^ option modifier for --no-foo
+    -> Parser (Maybe Bool)
+invertableSwitch' longopt shortopt defv enmod dismod = optional
+    ( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt)
+    <|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
+    )
+  where
+    nolongopt = "no-" ++ longopt
+
+
+
+    ---------------------
+    --[ Either Parser ]--
+    ---------------------
+
+
+platformParser :: String -> Either String PlatformRequest
+platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
+  Right r -> pure r
+  Left  e -> Left $ errorBundlePretty e
+ where
+  archP :: MP.Parsec Void Text Architecture
+  archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
+  platformP :: MP.Parsec Void Text PlatformRequest
+  platformP = choice'
+    [ (`PlatformRequest` FreeBSD)
+    <$> (archP <* MP.chunk "-")
+    <*> (  MP.chunk "portbld"
+        *> (   MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
+           <|> pure Nothing
+           )
+        <* MP.chunk "-freebsd"
+        )
+    , (`PlatformRequest` Darwin)
+    <$> (archP <* MP.chunk "-")
+    <*> (  MP.chunk "apple"
+        *> (   MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
+           <|> pure Nothing
+           )
+        <* MP.chunk "-darwin"
+        )
+    , (\a d mv -> PlatformRequest a (Linux d) mv)
+    <$> (archP <* MP.chunk "-")
+    <*> distroP
+    <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
+         )
+        <* MP.chunk "-linux"
+        )
+    ]
+  distroP :: MP.Parsec Void Text LinuxDistro
+  distroP = choice'
+    [ MP.chunk "debian" $> Debian
+    , MP.chunk "deb" $> Debian
+    , MP.chunk "ubuntu" $> Ubuntu
+    , MP.chunk "mint" $> Mint
+    , MP.chunk "fedora" $> Fedora
+    , MP.chunk "centos" $> CentOS
+    , MP.chunk "redhat" $> RedHat
+    , MP.chunk "alpine" $> Alpine
+    , MP.chunk "gentoo" $> Gentoo
+    , MP.chunk "exherbo" $> Exherbo
+    , MP.chunk "unknown" $> UnknownLinux
+    ]
+
+
+bindistParser :: String -> Either String URI
+bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
+
+
+absolutePathParser :: FilePath -> Either String FilePath
+absolutePathParser f = case isValid f && isAbsolute f of
+              True -> Right $ normalise f
+              False -> Left "Please enter a valid absolute filepath."
+
+isolateParser :: FilePath -> Either String FilePath
+isolateParser f = case isValid f of
+              True -> Right $ normalise f
+              False -> Left "Please enter a valid filepath for isolate dir."
+
+toolVersionEither :: String -> Either String ToolVersion
+toolVersionEither s' =
+  second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
+
+tagEither :: String -> Either String Tag
+tagEither s' = case fmap toLower s' of
+  "recommended" -> Right Recommended
+  "latest"      -> Right Latest
+  ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
+                                  Right x -> Right (Base x)
+                                  Left  _ -> Left $ "Invalid PVP version for base " <> ver'
+  other         -> Left $ "Unknown tag " <> other
+
+
+tVersionEither :: String -> Either String GHCTargetVersion
+tVersionEither =
+  first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
+
+
+toolParser :: String -> Either String Tool
+toolParser s' | t == T.pack "ghc"   = Right GHC
+              | t == T.pack "cabal" = Right Cabal
+              | t == T.pack "hls"   = Right HLS
+              | t == T.pack "stack" = Right Stack
+              | otherwise           = Left ("Unknown tool: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+criteriaParser :: String -> Either String ListCriteria
+criteriaParser s' | t == T.pack "installed" = Right ListInstalled
+                  | t == T.pack "set"       = Right ListSet
+                  | t == T.pack "available" = Right ListAvailable
+                  | otherwise               = Left ("Unknown criteria: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+toolVersionParser :: Parser ToolVersion
+toolVersionParser = verP' <|> toolP
+ where
+  verP' = ToolVersion <$> versionParser
+  toolP =
+    ToolTag
+      <$> option
+            (eitherReader tagEither)
+            (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
+
+
+
+
+keepOnParser :: String -> Either String KeepDirs
+keepOnParser s' | t == T.pack "always" = Right Always
+                | t == T.pack "errors" = Right Errors
+                | t == T.pack "never"  = Right Never
+                | otherwise            = Left ("Unknown keep value: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+downloaderParser :: String -> Either String Downloader
+downloaderParser s' | t == T.pack "curl"     = Right Curl
+                    | t == T.pack "wget"     = Right Wget
+#if defined(INTERNAL_DOWNLOADER)
+                    | t == T.pack "internal" = Right Internal
+#endif
+                    | otherwise = Left ("Unknown downloader value: " <> s')
+  where t = T.toLower (T.pack s')
+
+gpgParser :: String -> Either String GPGSetting
+gpgParser s' | t == T.pack "strict" = Right GPGStrict
+             | t == T.pack "lax"    = Right GPGLax
+             | t == T.pack "none"   = Right GPGNone
+             | otherwise = Left ("Unknown gpg setting value: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+
+    ------------------
+    --[ Completers ]--
+    ------------------
+
+tagCompleter :: Tool -> [String] -> Completer
+tagCompleter tool add = listIOCompleter $ do
+  dirs' <- liftIO getAllDirs
+  let loggerConfig = LoggerConfig
+        { lcPrintDebug   = False
+        , consoleOutter  = mempty
+        , fileOutter     = mempty
+        , fancyColors    = False
+        }
+  let appState = LeanAppState
+        (Settings True False Never Curl False GHCupURL True GPGNone False)
+        dirs'
+        defaultKeyBindings
+        loggerConfig
+
+  mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
+  case mGhcUpInfo of
+    VRight ghcupInfo -> do
+      let allTags = filter (/= Old)
+            $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
+      pure $ nub $ (add ++) $ fmap tagToString allTags
+    VLeft _ -> pure  (nub $ ["recommended", "latest"] ++ add)
+
+
+versionCompleter :: Maybe ListCriteria -> Tool -> Completer
+versionCompleter criteria tool = listIOCompleter $ do
+  dirs' <- liftIO getAllDirs
+  let loggerConfig = LoggerConfig
+        { lcPrintDebug   = False
+        , consoleOutter  = mempty
+        , fileOutter     = mempty
+        , fancyColors    = False
+        }
+  let settings = Settings True False Never Curl False GHCupURL True GPGNone False
+  let leanAppState = LeanAppState
+                   settings
+                   dirs'
+                   defaultKeyBindings
+                   loggerConfig
+  mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
+  mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
+  forFold mpFreq $ \pfreq -> do
+    forFold mGhcUpInfo $ \ghcupInfo -> do
+      let appState = AppState
+            settings
+            dirs'
+            defaultKeyBindings
+            ghcupInfo
+            pfreq
+            loggerConfig
+
+          runEnv = flip runReaderT appState
+
+      installedVersions <- runEnv $ listVersions (Just tool) criteria
+      return $ T.unpack . prettyVer . lVer <$> installedVersions
+
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+fromVersion :: ( HasLog env
+               , MonadFail m
+               , MonadReader env m
+               , HasGHCupInfo env
+               , HasDirs env
+               , MonadThrow m
+               , MonadIO m
+               , MonadCatch m
+               )
+            => Maybe ToolVersion
+            -> Tool
+            -> Excepts
+                 '[ TagNotFound
+                  , NextVerNotFound
+                  , NoToolVersionSet
+                  ] m (GHCTargetVersion, Maybe VersionInfo)
+fromVersion tv = fromVersion' (toSetToolVer tv)
+
+fromVersion' :: ( HasLog env
+                , MonadFail m
+                , MonadReader env m
+                , HasGHCupInfo env
+                , HasDirs env
+                , MonadThrow m
+                , MonadIO m
+                , MonadCatch m
+                )
+             => SetToolVersion
+             -> Tool
+             -> Excepts
+                  '[ TagNotFound
+                   , NextVerNotFound
+                   , NoToolVersionSet
+                   ] m (GHCTargetVersion, Maybe VersionInfo)
+fromVersion' SetRecommended tool = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  bimap mkTVer Just <$> getRecommended dls tool
+    ?? TagNotFound Recommended tool
+fromVersion' (SetToolVersion v) tool = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  let vi = getVersionInfo (_tvVersion v) tool dls
+  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
+    Left _ -> pure (v, vi)
+    Right pvpIn ->
+      lift (getLatestToolFor tool pvpIn dls) >>= \case
+        Just (pvp_, vi') -> do
+          v' <- lift $ pvpToVersion pvp_
+          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
+          pure (GHCTargetVersion (_tvTarget v) v', Just vi')
+        Nothing -> pure (v, vi)
+fromVersion' (SetToolTag Latest) tool = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
+fromVersion' (SetToolTag Recommended) tool = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
+fromVersion' (SetToolTag (Base pvp'')) GHC = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
+fromVersion' SetNext tool = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  next <- case tool of
+    GHC -> do
+      set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool
+      ghcs <- rights <$> lift getInstalledGHCs
+      (headMay
+        . tail
+        . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
+        . cycle
+        . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
+        . filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
+        $ ghcs) ?? NoToolVersionSet tool
+    Cabal -> do
+      set <- cabalSet !? NoToolVersionSet tool
+      cabals <- rights <$> lift getInstalledCabals
+      (fmap (GHCTargetVersion Nothing)
+        . headMay
+        . tail
+        . dropWhile (/= set)
+        . cycle
+        . sort
+        $ cabals) ?? NoToolVersionSet tool
+    HLS -> do
+      set <- hlsSet !? NoToolVersionSet tool
+      hlses <- rights <$> lift getInstalledHLSs
+      (fmap (GHCTargetVersion Nothing)
+        . headMay
+        . tail
+        . dropWhile (/= set)
+        . cycle
+        . sort
+        $ hlses) ?? NoToolVersionSet tool
+    Stack -> do
+      set <- stackSet !? NoToolVersionSet tool
+      stacks <- rights <$> lift getInstalledStacks
+      (fmap (GHCTargetVersion Nothing)
+        . headMay
+        . tail
+        . dropWhile (/= set)
+        . cycle
+        . sort
+        $ stacks) ?? NoToolVersionSet tool
+    GHCup -> fail "GHCup cannot be set"
+  let vi = getVersionInfo (_tvVersion next) tool dls
+  pure (next, vi)
+fromVersion' (SetToolTag t') tool =
+  throwE $ TagNotFound t' tool
+
+
+checkForUpdates :: ( MonadReader env m
+                   , HasGHCupInfo env
+                   , HasDirs env
+                   , HasPlatformReq env
+                   , MonadCatch m
+                   , HasLog env
+                   , MonadThrow m
+                   , MonadIO m
+                   , MonadFail m
+                   )
+                => m ()
+checkForUpdates = do
+  GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
+  lInstalled <- listVersions Nothing (Just ListInstalled)
+  let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
+
+  forM_ (getLatest dls GHCup) $ \(l, _) -> do
+    (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
+    when (l > ghc_ver)
+      $ logWarn $
+          "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
+
+  forM_ (getLatest dls GHC) $ \(l, _) -> do
+    let mghc_ver = latestInstalled GHC
+    forM mghc_ver $ \ghc_ver ->
+      when (l > ghc_ver)
+        $ logWarn $
+          "New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
+
+  forM_ (getLatest dls Cabal) $ \(l, _) -> do
+    let mcabal_ver = latestInstalled Cabal
+    forM mcabal_ver $ \cabal_ver ->
+      when (l > cabal_ver)
+        $ logWarn $
+          "New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
+
+  forM_ (getLatest dls HLS) $ \(l, _) -> do
+    let mhls_ver = latestInstalled HLS
+    forM mhls_ver $ \hls_ver ->
+      when (l > hls_ver)
+        $ logWarn $
+          "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
+
+  forM_ (getLatest dls Stack) $ \(l, _) -> do
+    let mstack_ver = latestInstalled Stack
+    forM mstack_ver $ \stack_ver ->
+      when (l > stack_ver)
+        $ logWarn $
+          "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

app/ghcup/GHCup/OptParse/Compile.hs

@@ -0,0 +1,517 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Compile where
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Utils.File
+import           GHCup.Types
+import           GHCup.Types.Optics
+import           GHCup.Utils
+import           GHCup.Utils.Logger
+import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Codec.Archive                  ( ArchiveResult )
+import           Control.Concurrent (threadDelay)
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Bifunctor
+import           Data.Functor
+import           Data.Maybe
+import           Data.Versions                  ( Version, prettyVer, version )
+import           Data.Text                      ( Text )
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import System.FilePath (isPathSeparator)
+import Text.Read (readEither)
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data CompileCommand = CompileGHC GHCCompileOptions
+                    | CompileHLS HLSCompileOptions
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data GHCCompileOptions = GHCCompileOptions
+  { targetGhc    :: Either Version GitBranch
+  , bootstrapGhc :: Either Version FilePath
+  , jobs         :: Maybe Int
+  , buildConfig  :: Maybe FilePath
+  , patchDir     :: Maybe FilePath
+  , crossTarget  :: Maybe Text
+  , addConfArgs  :: [Text]
+  , setCompile   :: Bool
+  , ovewrwiteVer :: Maybe Version
+  , buildFlavour :: Maybe String
+  , hadrian      :: Bool
+  , isolateDir   :: Maybe FilePath
+  }
+
+data HLSCompileOptions = HLSCompileOptions
+  { targetHLS    :: Either Version GitBranch
+  , jobs         :: Maybe Int
+  , setCompile   :: Bool
+  , ovewrwiteVer :: Maybe Version
+  , isolateDir   :: Maybe FilePath
+  , cabalProject :: Maybe FilePath
+  , cabalProjectLocal :: Maybe FilePath
+  , patchDir     :: Maybe FilePath
+  , targetGHCs   :: [ToolVersion]
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+compileP :: Parser CompileCommand
+compileP = subparser
+  (  command
+      "ghc"
+      (   CompileGHC
+      <$> info
+            (ghcCompileOpts <**> helper)
+            (  progDesc "Compile GHC from source"
+            <> footerDoc (Just $ text compileFooter)
+            )
+      )
+  <>  command
+      "hls"
+      (   CompileHLS
+      <$> info
+            (hlsCompileOpts <**> helper)
+            (  progDesc "Compile HLS from source"
+            <> footerDoc (Just $ text compileHLSFooter)
+            )
+      )
+  )
+ where
+  compileFooter = [s|Discussion:
+  Compiles and installs the specified GHC version into
+  a self-contained "~/.ghcup/ghc/<ghcver>" directory
+  and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
+
+  This also allows building a cross-compiler. Consult the documentation
+  first: <https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#configuring-the-build>
+
+ENV variables:
+  Various toolchain variables will be passed onto the ghc build system,
+  such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
+
+Examples:
+  # compile from known version
+  ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
+  # compile from git commit/reference
+  ghcup compile ghc -j 4 -g master -b 8.2.2
+  # specify path to bootstrap ghc
+  ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
+  # build cross compiler
+  ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
+
+  compileHLSFooter = [s|Discussion:
+  Compiles and installs the specified HLS version.
+  The last argument is a list of GHC versions to compile for.
+  These need to be available in PATH prior to compilation.
+
+Examples:
+  ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|]
+
+
+ghcCompileOpts :: Parser GHCCompileOptions
+ghcCompileOpts =
+  GHCCompileOptions
+    <$> ((Left <$> option
+          (eitherReader
+            (first (const "Not a valid version") . version . T.pack)
+          )
+          (short 'v' <> long "version" <> metavar "VERSION" <> help
+            "The tool version to compile"
+          )
+          ) <|>
+          (Right <$> (GitBranch <$> option
+          str
+          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
+            "The git commit/branch/ref to build from"
+          ) <*>
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
+          )))
+    <*> option
+          (eitherReader
+            (\x ->
+              (bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
+            )
+          )
+          (  short 'b'
+          <> long "bootstrap-ghc"
+          <> metavar "BOOTSTRAP_GHC"
+          <> help
+               "The GHC version (or full path) to bootstrap with (must be installed)"
+          )
+    <*> optional
+          (option
+            (eitherReader (readEither @Int))
+            (short 'j' <> long "jobs" <> metavar "JOBS" <> help
+              "How many jobs to use for make"
+            )
+          )
+    <*> optional
+          (option
+            str
+            (short 'c' <> long "config" <> metavar "CONFIG" <> help
+              "Absolute path to build config file"
+            )
+          )
+    <*> optional
+          (option
+            str
+            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+            )
+          )
+    <*> optional
+          (option
+            str
+            (short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
+              "Build cross-compiler for this platform"
+            )
+          )
+    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
+    <*> optional
+          (option
+            (eitherReader
+              (first (const "Not a valid version") . version . T.pack)
+            )
+            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
+              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            )
+          )
+    <*> optional
+          (option
+            str
+            (short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
+              "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+            )
+          )
+    <*> switch
+          (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
+          )
+    <*> optional
+          (option
+            (eitherReader isolateParser)
+            (  short 'i'
+            <> long "isolate"
+            <> metavar "DIR"
+            <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
+            )
+           )
+
+hlsCompileOpts :: Parser HLSCompileOptions
+hlsCompileOpts =
+  HLSCompileOptions
+    <$> ((Left <$> option
+          (eitherReader
+            (first (const "Not a valid version") . version . T.pack)
+          )
+          (short 'v' <> long "version" <> metavar "VERSION" <> help
+            "The tool version to compile"
+          )
+          ) <|>
+          (Right <$> (GitBranch <$> option
+          str
+          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
+            "The git commit/branch/ref to build from"
+          ) <*>
+          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
+          )))
+    <*> optional
+          (option
+            (eitherReader (readEither @Int))
+            (short 'j' <> long "jobs" <> metavar "JOBS" <> help
+              "How many jobs to use for make"
+            )
+          )
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
+    <*> optional
+          (option
+            (eitherReader
+              (first (const "Not a valid version") . version . T.pack)
+            )
+            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
+              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader isolateParser)
+            (  short 'i'
+            <> long "isolate"
+            <> metavar "DIR"
+            <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
+            )
+           )
+    <*> optional
+          (option
+            str
+            (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
+              "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader absolutePathParser)
+            (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
+              "Absolute path to a cabal.project.local to be used for the build. Will be copied over."
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader absolutePathParser)
+            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+            )
+          )
+    <*> some (toolVersionArgument Nothing (Just GHC))
+
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type GHCEffects = '[ AlreadyInstalled
+                  , BuildFailed
+                  , DigestError
+                  , GPGError
+                  , DownloadFailed
+                  , GHCupSetError
+                  , NoDownload
+                  , NotFoundInPATH
+                  , PatchFailed
+                  , UnknownArchive
+                  , TarDirDoesNotExist
+                  , NotInstalled
+                  , DirNotEmpty
+                  , ArchiveResult
+                  , FileDoesNotExistError
+                  , HadrianNotFound
+                  , InvalidBuildConfig
+                  , ProcessError
+                  , CopyError
+                  , BuildFailed
+                  ]
+type HLSEffects = '[ AlreadyInstalled
+                  , BuildFailed
+                  , DigestError
+                  , GPGError
+                  , DownloadFailed
+                  , GHCupSetError
+                  , NoDownload
+                  , NotFoundInPATH
+                  , PatchFailed
+                  , UnknownArchive
+                  , TarDirDoesNotExist
+                  , TagNotFound
+                  , NextVerNotFound
+                  , NoToolVersionSet
+                  , NotInstalled
+                  , DirNotEmpty
+                  , ArchiveResult
+                  ]
+
+
+
+runCompileGHC :: (MonadUnliftIO m, MonadIO m)
+              => (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a))
+              -> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a
+              -> m (VEither GHCEffects a)
+runCompileGHC runAppState =
+        runAppState
+        . runResourceT
+        . runE
+          @GHCEffects
+
+runCompileHLS :: (MonadUnliftIO m, MonadIO m)
+              => (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a))
+              -> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a
+              -> m (VEither HLSEffects a)
+runCompileHLS runAppState =
+        runAppState
+        . runResourceT
+        . runE
+          @HLSEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+compile :: ( Monad m
+           , MonadMask m
+           , MonadUnliftIO m
+           , MonadFail m
+           )
+      => CompileCommand
+      -> Settings
+      -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))
+      -> (ReaderT LeanAppState m () -> m ())
+      -> m ExitCode
+compile compileCommand settings runAppState runLogger = do
+  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
+  case compileCommand of
+    (CompileHLS HLSCompileOptions { .. }) -> do
+      runCompileHLS runAppState (do
+        case targetHLS of
+          Left targetVer -> do
+            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+            let vi = getVersionInfo targetVer HLS dls
+            forM_ (_viPreCompile =<< vi) $ \msg -> do
+              lift $ logInfo msg
+              lift $ logInfo
+                "...waiting for 5 seconds, you can still abort..."
+              liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+          Right _ -> pure ()
+        ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
+        targetVer <- liftE $ compileHLS
+                    targetHLS
+                    ghcs
+                    jobs
+                    ovewrwiteVer
+                    isolateDir
+                    cabalProject
+                    cabalProjectLocal
+                    patchDir
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        let vi = getVersionInfo targetVer HLS dls
+        when setCompile $ void $ liftE $
+          setHLS targetVer
+        pure (vi, targetVer)
+        )
+        >>= \case
+              VRight (vi, tv) -> do
+                runLogger $ logInfo
+                  "HLS successfully compiled and installed"
+                forM_ (_viPostInstall =<< vi) $ \msg ->
+                  runLogger $ logInfo msg
+                liftIO $ putStr (T.unpack $ prettyVer tv)
+                pure ExitSuccess
+              VLeft err@(V (BuildFailed tmpdir _)) -> do
+                case keepDirs settings of
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
+                        <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                        "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
+                pure $ ExitFailure 9
+              VLeft e -> do
+                runLogger $ logError $ T.pack $ prettyShow e
+                pure $ ExitFailure 9
+    (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
+      runLogger $ logError "Hadrian cross compile support is not yet implemented!"
+      pure $ ExitFailure 9
+    (CompileGHC GHCCompileOptions {..}) ->
+      runCompileGHC runAppState (do
+        case targetGhc of
+          Left targetVer -> do
+            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+            let vi = getVersionInfo targetVer GHC dls
+            forM_ (_viPreCompile =<< vi) $ \msg -> do
+              lift $ logInfo msg
+              lift $ logInfo
+                "...waiting for 5 seconds, you can still abort..."
+              liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+          Right _ -> pure ()
+        targetVer <- liftE $ compileGHC
+                    (first (GHCTargetVersion crossTarget) targetGhc)
+                    ovewrwiteVer
+                    bootstrapGhc
+                    jobs
+                    buildConfig
+                    patchDir
+                    addConfArgs
+                    buildFlavour
+                    hadrian
+                    isolateDir
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        let vi = getVersionInfo (_tvVersion targetVer) GHC dls
+        when setCompile $ void $ liftE $
+          setGHC targetVer SetGHCOnly
+        pure (vi, targetVer)
+        )
+        >>= \case
+              VRight (vi, tv) -> do
+                runLogger $ logInfo
+                  "GHC successfully compiled and installed"
+                forM_ (_viPostInstall =<< vi) $ \msg ->
+                  runLogger $ logInfo msg
+                liftIO $ putStr (T.unpack $ tVerToText tv)
+                pure ExitSuccess
+              VLeft (V (AlreadyInstalled _ v)) -> do
+                runLogger $ logWarn $
+                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
+                pure ExitSuccess
+              VLeft (V (DirNotEmpty fp)) -> do
+                runLogger $ logWarn $
+                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                pure $ ExitFailure 3
+              VLeft err@(V (BuildFailed tmpdir _)) -> do
+                case keepDirs settings of
+                  Never -> runLogger $ logError $ T.pack $ prettyShow err
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                        "Check the logs at " <> T.pack logsDir <> " and the build directory "
+                        <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                        "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
+                pure $ ExitFailure 9
+              VLeft e -> do
+                runLogger $ logError $ T.pack $ prettyShow e
+                pure $ ExitFailure 9

app/ghcup/GHCup/OptParse/Config.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Config where
+
+
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Bifunctor
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+
+import qualified Data.Text                     as T
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.YAML.Aeson               as Y
+import Control.Exception.Safe (MonadMask)
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data ConfigCommand
+  = ShowConfig
+  | SetConfig String String
+  | InitConfig
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+configP :: Parser ConfigCommand
+configP = subparser
+      (  command "init" initP
+      <> command "set"  setP -- [set] KEY VALUE at help lhs
+      <> command "show" showP
+      )
+    <|> argsP -- add show for a single option
+    <|> pure ShowConfig
+ where
+  initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
+  showP = info (pure ShowConfig) (progDesc "Show current config (default)")
+  setP  = info argsP (progDesc "Set config KEY to VALUE")
+  argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE")
+
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+configFooter :: String
+configFooter = [s|Examples:
+
+  # show current config
+  ghcup config
+
+  # initialize config
+  ghcup config init
+
+  # set <key> <value> configuration pair
+  ghcup config <key> <value>|]
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+formatConfig :: UserSettings -> String
+formatConfig = UTF8.toString . Y.encode1Strict
+
+
+updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
+updateSettings config' settings = do
+  settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config'
+  pure $ mergeConf settings' settings
+  where
+   mergeConf :: UserSettings -> Settings -> Settings
+   mergeConf UserSettings{..} Settings{..} =
+     let cache'      = fromMaybe cache uCache
+         noVerify'   = fromMaybe noVerify uNoVerify
+         keepDirs'   = fromMaybe keepDirs uKeepDirs
+         downloader' = fromMaybe downloader uDownloader
+         verbose'    = fromMaybe verbose uVerbose
+         urlSource'  = fromMaybe urlSource uUrlSource
+         noNetwork'  = fromMaybe noNetwork uNoNetwork
+         gpgSetting' = fromMaybe gpgSetting uGPGSetting
+     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+config :: ( Monad m
+          , MonadMask m
+          , MonadUnliftIO m
+          , MonadFail m
+          )
+     => ConfigCommand
+     -> Settings
+     -> KeyBindings
+     -> (ReaderT LeanAppState m () -> m ())
+     -> m ExitCode
+config configCommand settings keybindings runLogger = case configCommand of
+  InitConfig -> do
+    path <- getConfigFilePath
+    liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
+    runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
+    pure ExitSuccess
+
+  ShowConfig -> do
+    liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
+    pure ExitSuccess
+
+  (SetConfig k v) -> do
+    case v of
+      "" -> do
+        runLogger $ logError "Empty values are not allowed"
+        pure $ ExitFailure 55
+      _  -> do
+        r <- runE @'[JSONError] $ do
+          settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
+          path <- liftIO getConfigFilePath
+          liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
+          lift $ runLogger $ logDebug $ T.pack $ show settings'
+          pure ()
+
+        case r of
+            VRight _ -> pure ExitSuccess
+            VLeft (V (JSONDecodeError e)) -> do
+              runLogger $ logError $ "Error decoding config: " <> T.pack e
+              pure $ ExitFailure 65
+            VLeft _ -> pure $ ExitFailure 65

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.DInfo where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Version
+import           GHCup.Types
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.Logger
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import GHCup.Utils.File
+import Language.Haskell.TH
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+describe_result :: String
+describe_result = $( LitE . StringL <$>
+                     runIO (do
+                             CapturedProcess{..} <-  do
+                              dirs <- liftIO getAllDirs
+                              let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)
+                                               dirs
+                                               defaultKeyBindings
+                              flip runReaderT settings $ executeOut "git" ["describe"] Nothing
+                             case _exitCode of
+                               ExitSuccess   -> pure . T.unpack . decUTF8Safe' $ _stdOut
+                               ExitFailure _ -> pure numericVer
+                     )
+                   )
+
+
+prettyDebugInfo :: DebugInfo -> String
+prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
+  "==========" <> "\n" <>
+  "GHCup base dir: " <> diBaseDir <> "\n" <>
+  "GHCup bin dir: " <> diBinDir <> "\n" <>
+  "GHCup GHC directory: " <> diGHCDir <> "\n" <>
+  "GHCup cache directory: " <> diCacheDir <> "\n" <>
+  "Architecture: " <> prettyShow diArch <> "\n" <>
+  "Platform: " <> prettyShow diPlatform <> "\n" <>
+  "Version: " <> describe_result
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
+
+runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
+             -> Excepts DInfoEffects (ReaderT env m) a
+             -> m (VEither DInfoEffects a)
+runDebugInfo runAppState =
+        runAppState
+        . runE
+          @DInfoEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+dinfo :: ( Monad m
+         , MonadMask m
+         , MonadUnliftIO m
+         , MonadFail m
+         , Alternative m
+         )
+      => (ReaderT AppState m (VEither DInfoEffects DebugInfo)
+          -> m (VEither DInfoEffects DebugInfo))
+      -> (ReaderT LeanAppState m () -> m ())
+      -> m ExitCode
+dinfo runAppState runLogger = do
+  runDebugInfo runAppState (liftE getDebugInfo)
+    >>= \case
+          VRight di -> do
+            liftIO $ putStrLn $ prettyDebugInfo di
+            pure ExitSuccess
+          VLeft e -> do
+            runLogger $ logError $ T.pack $ prettyShow e
+            pure $ ExitFailure 8

app/ghcup/GHCup/OptParse/GC.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.GC where
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data GCOptions = GCOptions
+  { gcOldGHC :: Bool
+  , gcProfilingLibs :: Bool
+  , gcShareDir :: Bool
+  , gcHLSNoGHC :: Bool
+  , gcCache :: Bool
+  , gcTmp :: Bool
+  }
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+gcP :: Parser GCOptions
+gcP =
+  GCOptions
+  <$> 
+    switch
+      (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
+  <*> 
+    switch
+      (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
+  <*> 
+    switch
+      (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
+  <*> 
+    switch
+      (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
+  <*> 
+    switch
+      (short 'c' <> long "cache" <> help "GC the GHCup cache")
+  <*> 
+    switch
+      (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+gcFooter :: String
+gcFooter = [s|Discussion:
+  Performs garbage collection. If no switches are specified, does nothing.|]
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type GCEffects = '[ NotInstalled ]
+
+
+runGC :: MonadUnliftIO m
+      => (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
+      -> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
+      -> m (VEither GCEffects a)
+runGC runAppState =
+  runAppState
+    . runResourceT
+    . runE
+      @GCEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+gc :: ( Monad m
+      , MonadMask m
+      , MonadUnliftIO m
+      , MonadFail m
+      )
+   => GCOptions
+   -> (forall a. ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
+   -> (ReaderT LeanAppState m () -> m ())
+   -> m ExitCode
+gc GCOptions{..} runAppState runLogger = runGC runAppState (do
+  when gcOldGHC rmOldGHC
+  lift $ when gcProfilingLibs rmProfilingLibs
+  lift $ when gcShareDir rmShareDir
+  lift $ when gcHLSNoGHC rmHLSNoGHC
+  lift $ when gcCache rmCache
+  lift $ when gcTmp rmTmp
+   ) >>= \case
+            VRight _ -> do
+                  pure ExitSuccess
+            VLeft e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 27

app/ghcup/GHCup/OptParse/Install.hs

@@ -0,0 +1,464 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module GHCup.OptParse.Install where
+
+
+
+
+import           GHCup.OptParse.Common
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.File
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+import           Codec.Archive
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Either
+import           Data.Functor
+import           Data.Maybe
+import           Data.Versions           hiding ( str )
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+import           URI.ByteString
+
+import qualified Data.Text                     as T
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data InstallCommand = InstallGHC InstallOptions
+                    | InstallCabal InstallOptions
+                    | InstallHLS InstallOptions
+                    | InstallStack InstallOptions
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data InstallOptions = InstallOptions
+  { instVer      :: Maybe ToolVersion
+  , instPlatform :: Maybe PlatformRequest
+  , instBindist  :: Maybe URI
+  , instSet      :: Bool
+  , isolateDir   :: Maybe FilePath
+  , forceInstall :: Bool
+  }
+
+
+
+    ---------------
+    --[ Footers ]--
+    ---------------
+
+installCabalFooter :: String
+installCabalFooter = [s|Discussion:
+  Installs the specified cabal-install version (or a recommended default one)
+  into "~/.ghcup/bin", so it can be overwritten by later
+  "cabal install cabal-install", which installs into "~/.cabal/bin" by
+  default. Make sure to set up your PATH appropriately, so the cabal
+  installation takes precedence.|]
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+installParser :: Parser (Either InstallCommand InstallOptions)
+installParser =
+  (Left <$> subparser
+      (  command
+          "ghc"
+          (   InstallGHC
+          <$> info
+                (installOpts (Just GHC) <**> helper)
+                (  progDesc "Install GHC"
+                <> footerDoc (Just $ text installGHCFooter)
+                )
+          )
+      <> command
+           "cabal"
+           (   InstallCabal
+           <$> info
+                 (installOpts (Just Cabal) <**> helper)
+                 (  progDesc "Install Cabal"
+                 <> footerDoc (Just $ text installCabalFooter)
+                 )
+           )
+      <> command
+           "hls"
+           (   InstallHLS
+           <$> info
+                 (installOpts (Just HLS) <**> helper)
+                 (  progDesc "Install haskell-language-server"
+                 <> footerDoc (Just $ text installHLSFooter)
+                 )
+           )
+      <> command
+           "stack"
+           (   InstallStack
+           <$> info
+                 (installOpts (Just Stack) <**> helper)
+                 (  progDesc "Install stack"
+                 <> footerDoc (Just $ text installStackFooter)
+                 )
+           )
+      )
+    )
+    <|> (Right <$> installOpts Nothing)
+ where
+  installHLSFooter :: String
+  installHLSFooter = [s|Discussion:
+  Installs haskell-language-server binaries and wrapper
+  into "~/.ghcup/bin"
+
+Examples:
+  # install recommended HLS
+  ghcup install hls|]
+
+  installStackFooter :: String
+  installStackFooter = [s|Discussion:
+  Installs stack binaries into "~/.ghcup/bin"
+
+Examples:
+  # install recommended Stack
+  ghcup install stack|]
+
+  installGHCFooter :: String
+  installGHCFooter = [s|Discussion:
+  Installs the specified GHC version (or a recommended default one) into
+  a self-contained "~/.ghcup/ghc/<ghcver>" directory
+  and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
+
+Examples:
+  # install recommended GHC
+  ghcup install ghc
+
+  # install latest GHC
+  ghcup install ghc latest
+
+  # install GHC 8.10.2
+  ghcup install ghc 8.10.2
+
+  # install GHC head fedora bindist
+  ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
+
+
+installOpts :: Maybe Tool -> Parser InstallOptions
+installOpts tool =
+  (\p (u, v) b is f -> InstallOptions v p u b is f)
+    <$> optional
+          (option
+            (eitherReader platformParser)
+            (  short 'p'
+            <> long "platform"
+            <> metavar "PLATFORM"
+            <> help
+                 "Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
+            )
+          )
+    <*> (   (   (,)
+            <$> optional
+                  (option
+                    (eitherReader bindistParser)
+                    (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
+                      "Install the specified version from this bindist"
+                    )
+                  )
+            <*> (Just <$> toolVersionArgument Nothing tool)
+            )
+        <|> pure (Nothing, Nothing)
+        )
+    <*> flag
+          False
+          True
+          (long "set" <> help
+            "Set as active version after install"
+          )
+    <*> optional
+          (option
+           (eitherReader isolateParser)
+           (  short 'i'
+           <> long "isolate"
+           <> metavar "DIR"
+           <> help "install in an isolated dir instead of the default one"
+           )
+          )
+    <*> switch
+          (short 'f' <> long "force" <> help "Force install")
+          
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+installToolFooter :: String
+installToolFooter = [s|Discussion:
+  Installs GHC or cabal. When no command is given, installs GHC
+  with the specified version/tag.
+  It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+type InstallEffects = '[ AlreadyInstalled
+                       , UnknownArchive
+                       , ArchiveResult
+                       , FileDoesNotExistError
+                       , CopyError
+                       , NotInstalled
+                       , DirNotEmpty
+                       , NoDownload
+                       , NotInstalled
+                       , BuildFailed
+                       , TagNotFound
+                       , DigestError
+                       , GPGError
+                       , DownloadFailed
+                       , TarDirDoesNotExist
+                       , NextVerNotFound
+                       , NoToolVersionSet
+                       , FileAlreadyExistsError
+                       , ProcessError
+                       ]
+
+
+runInstTool :: AppState
+            -> Maybe PlatformRequest
+            -> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
+            -> IO (VEither InstallEffects a)
+runInstTool appstate' mInstPlatform =
+  flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
+  . runResourceT
+  . runE
+    @InstallEffects
+
+
+
+    -------------------
+    --[ Entrypoints ]--
+    -------------------
+
+
+install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
+install installCommand settings getAppState' runLogger = case installCommand of
+  (Right iopts) -> do
+    runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
+    installGHC iopts
+  (Left (InstallGHC iopts)) -> installGHC iopts
+  (Left (InstallCabal iopts)) -> installCabal iopts
+  (Left (InstallHLS iopts)) -> installHLS iopts
+  (Left (InstallStack iopts)) -> installStack iopts
+ where
+  installGHC :: InstallOptions -> IO ExitCode
+  installGHC InstallOptions{..} = do
+    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
+    (case instBindist of
+       Nothing -> runInstTool s' instPlatform $ do
+         (v, vi) <- liftE $ fromVersion instVer GHC
+         liftE $ installGHCBin
+                   (_tvVersion v)
+                   isolateDir
+                   forceInstall
+         when instSet $ void $ liftE $ setGHC v SetGHCOnly
+         pure vi
+       Just uri -> do
+         runInstTool s'{ settings = settings {noVerify = True}} instPlatform $ do
+           (v, vi) <- liftE $ fromVersion instVer GHC
+           liftE $ installGHCBindist
+                     (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
+                     (_tvVersion v)
+                     isolateDir
+                     forceInstall
+           when instSet $ void $ liftE $ setGHC v SetGHCOnly
+           pure vi
+      )
+        >>= \case
+              VRight vi -> do
+                runLogger $ logInfo "GHC installation successful"
+                forM_ (_viPostInstall =<< vi) $ \msg ->
+                  runLogger $ logInfo msg
+                pure ExitSuccess
+              VLeft (V (AlreadyInstalled _ v)) -> do
+                runLogger $ logWarn $
+                  "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"
+                pure ExitSuccess
+              VLeft (V (DirNotEmpty fp)) -> do
+                runLogger $ logWarn $
+                  "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."
+                pure $ ExitFailure 3
+              VLeft err@(V (BuildFailed tmpdir _)) -> do
+                case keepDirs settings of
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                    "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
+                    "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
+                pure $ ExitFailure 3
+              VLeft e -> do
+                runLogger $ do
+                  logError $ T.pack $ prettyShow e
+                  logError $ "Also check the logs in " <> T.pack logsDir
+                pure $ ExitFailure 3
+
+
+  installCabal :: InstallOptions -> IO ExitCode
+  installCabal InstallOptions{..} = do
+    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
+    (case instBindist of
+       Nothing -> runInstTool s' instPlatform $ do
+         (v, vi) <- liftE $ fromVersion instVer Cabal
+         liftE $ installCabalBin
+                   (_tvVersion v)
+                   isolateDir
+                   forceInstall
+         pure vi
+       Just uri -> do
+         runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
+           (v, vi) <- liftE $ fromVersion instVer Cabal
+           liftE $ installCabalBindist 
+                     (DownloadInfo uri Nothing "")
+                     (_tvVersion v)
+                     isolateDir
+                     forceInstall
+           pure vi
+      )
+      >>= \case
+            VRight vi -> do
+              runLogger $ logInfo "Cabal installation successful"
+              forM_ (_viPostInstall =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft (V (AlreadyInstalled _ v)) -> do
+              runLogger $ logWarn $
+                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp)) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
+            VLeft e -> do
+              runLogger $ do
+                logError $ T.pack $ prettyShow e
+                logError $ "Also check the logs in " <> T.pack logsDir
+              pure $ ExitFailure 4
+
+  installHLS :: InstallOptions -> IO ExitCode
+  installHLS InstallOptions{..} = do
+     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
+     (case instBindist of
+       Nothing -> runInstTool s' instPlatform $ do
+         (v, vi) <- liftE $ fromVersion instVer HLS
+         liftE $ installHLSBin
+                   (_tvVersion v)
+                   isolateDir
+                   forceInstall
+         pure vi
+       Just uri -> do
+         runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
+           (v, vi) <- liftE $ fromVersion instVer HLS
+           liftE $ installHLSBindist
+                     (DownloadInfo uri Nothing "")
+                     (_tvVersion v)
+                     isolateDir
+                     forceInstall
+           pure vi
+      )
+      >>= \case
+            VRight vi -> do
+              runLogger $ logInfo "HLS installation successful"
+              forM_ (_viPostInstall =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft (V (AlreadyInstalled _ v)) -> do
+              runLogger $ logWarn $
+                  "HLS ver "
+                <> prettyVer v
+                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
+                <> prettyVer v
+                <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp)) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
+            VLeft e -> do
+              runLogger $ do
+                logError $ T.pack $ prettyShow e
+                logError $ "Also check the logs in " <> T.pack logsDir
+              pure $ ExitFailure 4
+
+  installStack :: InstallOptions -> IO ExitCode
+  installStack InstallOptions{..} = do
+     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
+     (case instBindist of
+        Nothing -> runInstTool s' instPlatform $ do
+          (v, vi) <- liftE $ fromVersion instVer Stack
+          liftE $ installStackBin
+                    (_tvVersion v)
+                    isolateDir
+                    forceInstall
+          pure vi
+        Just uri -> do
+          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
+            (v, vi) <- liftE $ fromVersion instVer Stack
+            liftE $ installStackBindist
+                      (DownloadInfo uri Nothing "")
+                      (_tvVersion v)
+                      isolateDir
+                      forceInstall
+            pure vi
+      )
+      >>= \case
+            VRight vi -> do
+              runLogger $ logInfo "Stack installation successful"
+              forM_ (_viPostInstall =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft (V (AlreadyInstalled _ v)) -> do
+              runLogger $ logWarn $
+                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
+              pure ExitSuccess
+            VLeft (V (FileAlreadyExistsError fp)) -> do
+              runLogger $ logWarn $
+                "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
+              pure $ ExitFailure 3
+            VLeft e -> do
+              runLogger $ do
+                logError $ T.pack $ prettyShow e
+                logError $ "Also check the logs in " <> T.pack logsDir
+              pure $ ExitFailure 4
+

app/ghcup/GHCup/OptParse/List.hs

@@ -0,0 +1,268 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.List where
+
+
+
+
+import           GHCup
+import           GHCup.Types
+import           GHCup.OptParse.Common
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Char
+import           Data.List                      ( intercalate, sort )
+import           Data.Functor
+import           Data.Maybe
+import           Data.Versions           hiding ( str )
+import           Data.Void
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           System.Console.Pretty   hiding ( color )
+
+import qualified Data.Text                     as T
+import qualified System.Console.Pretty         as Pretty
+import Control.Exception.Safe (MonadMask)
+import qualified Text.Megaparsec               as MP
+import qualified Text.Megaparsec.Char          as MPC
+
+
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data ListOptions = ListOptions
+  { loTool     :: Maybe Tool
+  , lCriteria  :: Maybe ListCriteria
+  , lRawFormat :: Bool
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+listOpts :: Parser ListOptions
+listOpts =
+  ListOptions
+    <$> optional
+          (option
+            (eitherReader toolParser)
+            (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
+              "Tool to list versions for. Default is all"
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader criteriaParser)
+            (  short 'c'
+            <> long "show-criteria"
+            <> metavar "<installed|set|available>"
+            <> help "Show only installed/set/available tool versions"
+            )
+          )
+    <*> switch
+          (short 'r' <> long "raw-format" <> help "More machine-parsable format"
+          )
+
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+printListResult :: Bool -> Bool -> [ListResult] -> IO ()
+printListResult no_color raw lr = do
+
+  let
+    color | raw || no_color = (\_ x -> x)
+          | otherwise       = Pretty.color
+
+  let
+    printTag Recommended        = color Green "recommended"
+    printTag Latest             = color Yellow "latest"
+    printTag Prerelease         = color Red "prerelease"
+    printTag (Base       pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
+    printTag (UnknownTag t    ) = t
+    printTag Old                = ""
+
+  let
+    rows =
+      (\x -> if raw
+          then x
+          else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
+        )
+        . fmap
+            (\ListResult {..} ->
+              let marks = if
+#if defined(IS_WINDOWS)
+                    | lSet       -> (color Green "IS")
+                    | lInstalled -> (color Green "I ")
+                    | otherwise  -> (color Red "X ")
+#else
+                    | lSet       -> (color Green "✔✔")
+                    | lInstalled -> (color Green "✓ ")
+                    | otherwise  -> (color Red "✗ ")
+#endif
+              in
+                (if raw then [] else [marks])
+                  ++ [ fmap toLower . show $ lTool
+                     , case lCross of
+                       Nothing -> T.unpack . prettyVer $ lVer
+                       Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
+                     , intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
+                     , intercalate ","
+                     $  (if hlsPowered
+                          then [color Green "hls-powered"]
+                          else mempty
+                        )
+                     ++ (if fromSrc then [color Blue "compiled"] else mempty)
+                     ++ (if lStray then [color Yellow "stray"] else mempty)
+                     ++ (if lNoBindist
+                          then [color Red "no-bindist"]
+                          else mempty
+                        )
+                     ]
+            )
+        $ lr
+  let cols =
+        foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
+      lengths = fmap (maximum . fmap strWidth) cols
+      padded  = fmap (\xs -> zipWith padTo xs lengths) rows
+
+  forM_ padded $ \row -> putStrLn $ unwords row
+ where
+
+  padTo str' x =
+    let lstr = strWidth str'
+        add' = x - lstr
+    in  if add' < 0 then str' else str' ++ replicate add' ' '
+
+  -- | Calculate the render width of a string, considering
+  -- wide characters (counted as double width), ANSI escape codes
+  -- (not counted), and line breaks (in a multi-line string, the longest
+  -- line determines the width).
+  strWidth :: String -> Int
+  strWidth =
+    maximum
+      . (0 :)
+      . map (foldr (\a b -> charWidth a + b) 0)
+      . lines
+      . stripAnsi
+
+  -- | Strip ANSI escape sequences from a string.
+  --
+  -- >>> stripAnsi "\ESC[31m-1\ESC[m"
+  -- "-1"
+  stripAnsi :: String -> String
+  stripAnsi s' =
+    case
+        MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
+      of
+        Nothing -> error "Bad ansi escape"  -- PARTIAL: should not happen
+        Just xs -> concat xs
+   where
+      -- This parses lots of invalid ANSI escape codes, but that should be fine
+    ansi =
+      MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
+          Void
+          String
+          Char
+    digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
+    suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
+
+  -- | Get the designated render width of a character: 0 for a combining
+  -- character, 1 for a regular character, 2 for a wide character.
+  -- (Wide characters are rendered as exactly double width in apps and
+  -- fonts that support it.) (From Pandoc.)
+  charWidth :: Char -> Int
+  charWidth c = case c of
+    _ | c < '\x0300'                     -> 1
+      | c >= '\x0300' && c <= '\x036F'   -> 0
+      |  -- combining
+        c >= '\x0370' && c <= '\x10FC'   -> 1
+      | c >= '\x1100' && c <= '\x115F'   -> 2
+      | c >= '\x1160' && c <= '\x11A2'   -> 1
+      | c >= '\x11A3' && c <= '\x11A7'   -> 2
+      | c >= '\x11A8' && c <= '\x11F9'   -> 1
+      | c >= '\x11FA' && c <= '\x11FF'   -> 2
+      | c >= '\x1200' && c <= '\x2328'   -> 1
+      | c >= '\x2329' && c <= '\x232A'   -> 2
+      | c >= '\x232B' && c <= '\x2E31'   -> 1
+      | c >= '\x2E80' && c <= '\x303E'   -> 2
+      | c == '\x303F'                    -> 1
+      | c >= '\x3041' && c <= '\x3247'   -> 2
+      | c >= '\x3248' && c <= '\x324F'   -> 1
+      | -- ambiguous
+        c >= '\x3250' && c <= '\x4DBF'   -> 2
+      | c >= '\x4DC0' && c <= '\x4DFF'   -> 1
+      | c >= '\x4E00' && c <= '\xA4C6'   -> 2
+      | c >= '\xA4D0' && c <= '\xA95F'   -> 1
+      | c >= '\xA960' && c <= '\xA97C'   -> 2
+      | c >= '\xA980' && c <= '\xABF9'   -> 1
+      | c >= '\xAC00' && c <= '\xD7FB'   -> 2
+      | c >= '\xD800' && c <= '\xDFFF'   -> 1
+      | c >= '\xE000' && c <= '\xF8FF'   -> 1
+      | -- ambiguous
+        c >= '\xF900' && c <= '\xFAFF'   -> 2
+      | c >= '\xFB00' && c <= '\xFDFD'   -> 1
+      | c >= '\xFE00' && c <= '\xFE0F'   -> 1
+      | -- ambiguous
+        c >= '\xFE10' && c <= '\xFE19'   -> 2
+      | c >= '\xFE20' && c <= '\xFE26'   -> 1
+      | c >= '\xFE30' && c <= '\xFE6B'   -> 2
+      | c >= '\xFE70' && c <= '\xFEFF'   -> 1
+      | c >= '\xFF01' && c <= '\xFF60'   -> 2
+      | c >= '\xFF61' && c <= '\x16A38'  -> 1
+      | c >= '\x1B000' && c <= '\x1B001' -> 2
+      | c >= '\x1D000' && c <= '\x1F1FF' -> 1
+      | c >= '\x1F200' && c <= '\x1F251' -> 2
+      | c >= '\x1F300' && c <= '\x1F773' -> 1
+      | c >= '\x20000' && c <= '\x3FFFD' -> 2
+      | otherwise                        -> 1
+
+
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+list :: ( Monad m
+         , MonadMask m
+         , MonadUnliftIO m
+         , MonadFail m
+         )
+      => ListOptions
+      -> Bool
+      -> (ReaderT AppState m ExitCode -> m ExitCode)
+      -> m ExitCode
+list ListOptions{..} no_color runAppState =
+  runAppState (do
+      l <- listVersions loTool lCriteria
+      liftIO $ printListResult no_color lRawFormat l
+      pure ExitSuccess
+    )

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Nuke where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import Control.DeepSeq
+import Control.Exception
+import Control.Concurrent (threadDelay)
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type NukeEffects = '[ NotInstalled ]
+
+
+runNuke :: AppState
+        -> Excepts NukeEffects (ReaderT AppState m) a
+        -> m (VEither NukeEffects a)
+runNuke s' =
+  flip runReaderT s' . runE @NukeEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+nuke :: ( Monad m
+        , MonadMask m
+        , MonadUnliftIO m
+        , MonadFail m
+        )
+     => IO AppState
+     -> (ReaderT LeanAppState m () -> m ())
+     -> m ExitCode
+nuke appState runLogger = do
+  s' <- liftIO appState
+  void $ liftIO $ evaluate $ force s'
+  runNuke s' (do
+       lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
+       lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
+       liftIO $ threadDelay 10000000  -- wait 10s
+
+       lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
+       lift $ logInfo "Nuking in 3...2...1"
+  
+       lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
+
+       forM_ lInstalled (liftE . rmTool)
+
+       lift rmGhcupDirs
+
+       ) >>= \case
+                VRight leftOverFiles
+                  | null leftOverFiles -> do
+                      runLogger $ logInfo "Nuclear Annihilation complete!"
+                      pure ExitSuccess
+                  | otherwise -> do
+                      runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
+                      liftIO $ forM_ leftOverFiles putStrLn
+                      pure ExitSuccess
+
+                VLeft e -> do
+                  runLogger $ logError $ T.pack $ prettyShow e
+                  pure $ ExitFailure 15

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -0,0 +1,219 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Prefetch where
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import GHCup.Utils.Prelude
+import GHCup.Download (getDownloadsF)
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
+                     | PrefetchCabal PrefetchOptions (Maybe ToolVersion)
+                     | PrefetchHLS PrefetchOptions (Maybe ToolVersion)
+                     | PrefetchStack PrefetchOptions (Maybe ToolVersion)
+                     | PrefetchMetadata
+
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data PrefetchOptions = PrefetchOptions {
+  pfCacheDir :: Maybe FilePath
+}
+
+data PrefetchGHCOptions = PrefetchGHCOptions {
+    pfGHCSrc :: Bool
+  , pfGHCCacheDir :: Maybe FilePath
+}
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+prefetchP :: Parser PrefetchCommand
+prefetchP = subparser
+  (  command
+      "ghc"
+      (info 
+        (PrefetchGHC
+          <$> (PrefetchGHCOptions
+                <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
+                <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <*>  optional (toolVersionArgument Nothing (Just GHC)) )
+        ( progDesc "Download GHC assets for installation")
+      )
+      <>
+     command
+      "cabal"
+      (info 
+        (PrefetchCabal
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))
+        ( progDesc "Download cabal assets for installation")
+      )
+      <>
+     command
+      "hls"
+      (info 
+        (PrefetchHLS
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))
+        ( progDesc "Download HLS assets for installation")
+      )
+      <>
+     command
+      "stack"
+      (info 
+        (PrefetchStack
+          <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
+          <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))
+        ( progDesc "Download stack assets for installation")
+      )
+      <>
+     command
+      "metadata"
+      (PrefetchMetadata <$ info
+        helper
+        ( progDesc "Download ghcup's metadata, needed for various operations")
+      )
+  )
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+prefetchFooter :: String
+prefetchFooter = [s|Discussion:
+  Prefetches tools or assets into "~/.ghcup/cache" directory. This can
+  be then combined later with '--offline' flag, ensuring all assets that
+  are required for offline use have been prefetched.
+
+Examples:
+  ghcup prefetch metadata
+  ghcup prefetch ghc 8.10.5
+  ghcup --offline install ghc 8.10.5|]
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type PrefetchEffects = '[ TagNotFound
+                        , NextVerNotFound
+                        , NoToolVersionSet
+                        , NoDownload
+                        , DigestError
+                        , GPGError
+                        , DownloadFailed
+                        , JSONError
+                        , FileDoesNotExistError ]
+
+
+runPrefetch :: MonadUnliftIO m
+            => (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
+            -> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
+            -> m (VEither PrefetchEffects a)
+runPrefetch runAppState =
+  runAppState
+  . runResourceT
+  . runE
+    @PrefetchEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+prefetch :: ( Monad m
+            , MonadMask m
+            , MonadUnliftIO m
+            , MonadFail m
+            )
+         => PrefetchCommand
+         -> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
+         -> (ReaderT LeanAppState m () -> m ())
+         -> m ExitCode
+prefetch prefetchCommand runAppState runLogger =
+  runPrefetch runAppState (do
+    case prefetchCommand of
+      PrefetchGHC
+        (PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
+          forM_ pfCacheDir (liftIO . createDirRecursive')
+          (v, _) <- liftE $ fromVersion mt GHC
+          if pfGHCSrc
+          then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
+          else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
+      PrefetchCabal PrefetchOptions {pfCacheDir} mt   -> do
+        forM_ pfCacheDir (liftIO . createDirRecursive')
+        (v, _) <- liftE $ fromVersion mt Cabal
+        liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
+      PrefetchHLS PrefetchOptions {pfCacheDir} mt   -> do
+        forM_ pfCacheDir (liftIO . createDirRecursive')
+        (v, _) <- liftE $ fromVersion mt HLS
+        liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
+      PrefetchStack PrefetchOptions {pfCacheDir} mt   -> do
+        forM_ pfCacheDir (liftIO . createDirRecursive')
+        (v, _) <- liftE $ fromVersion mt Stack
+        liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
+      PrefetchMetadata -> do
+        _ <- liftE getDownloadsF
+        pure ""
+       ) >>= \case
+                VRight _ -> do
+                      pure ExitSuccess
+                VLeft e -> do
+                  runLogger $ logError $ T.pack $ prettyShow e
+                  pure $ ExitFailure 15

app/ghcup/GHCup/OptParse/Rm.hs

@@ -0,0 +1,232 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Rm where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.Optics
+import           GHCup.Utils
+import           GHCup.Utils.Logger
+import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Data.Versions           hiding ( str )
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data RmCommand = RmGHC RmOptions
+               | RmCabal Version
+               | RmHLS Version
+               | RmStack Version
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data RmOptions = RmOptions
+  { ghcVer :: GHCTargetVersion
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+rmParser :: Parser (Either RmCommand RmOptions)
+rmParser =
+  (Left <$> subparser
+      (  command
+          "ghc"
+          (RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
+      <> command
+           "cabal"
+           (   RmCabal
+           <$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
+                    (progDesc "Remove Cabal version")
+           )
+      <> command
+           "hls"
+           (   RmHLS
+           <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
+                    (progDesc "Remove haskell-language-server version")
+           )
+      <> command
+           "stack"
+           (   RmStack
+           <$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
+                    (progDesc "Remove stack version")
+           )
+      )
+    )
+    <|> (Right <$> rmOpts Nothing)
+
+
+
+rmOpts :: Maybe Tool -> Parser RmOptions
+rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool
+
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+rmFooter :: String
+rmFooter = [s|Discussion:
+  Remove the given GHC or cabal version. When no command is given,
+  defaults to removing GHC with the specified version.
+  It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type RmEffects = '[ NotInstalled ]
+
+
+runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
+            -> Excepts RmEffects (ReaderT env m) a
+            -> m (VEither RmEffects a)
+runRm runAppState =
+    runAppState
+    . runE
+      @RmEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+rm :: ( Monad m
+      , MonadMask m
+      , MonadUnliftIO m
+      , MonadFail m
+      )
+   => Either RmCommand RmOptions
+   -> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
+       -> m (VEither RmEffects (Maybe VersionInfo)))
+   -> (ReaderT LeanAppState m () -> m ())
+   -> m ExitCode
+rm rmCommand runAppState runLogger = case rmCommand of
+  (Right rmopts) -> do
+    runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
+    rmGHC' rmopts
+  (Left (RmGHC rmopts)) -> rmGHC' rmopts
+  (Left (RmCabal rmopts)) -> rmCabal' rmopts
+  (Left (RmHLS rmopts)) -> rmHLS' rmopts
+  (Left (RmStack rmopts)) -> rmStack' rmopts
+
+ where
+  rmGHC' RmOptions{..} =
+    runRm runAppState (do
+        liftE $
+          rmGHCVer ghcVer
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
+      )
+      >>= \case
+            VRight vi -> do
+              forM_ (_viPostRemove =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 7
+
+  rmCabal' tv =
+    runRm runAppState (do
+        liftE $
+          rmCabalVer tv
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        pure (getVersionInfo tv Cabal dls)
+      )
+      >>= \case
+            VRight vi -> do
+              forM_ (_viPostRemove =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 15
+
+  rmHLS' tv =
+    runRm runAppState (do
+        liftE $
+          rmHLSVer tv
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        pure (getVersionInfo tv HLS dls)
+      )
+      >>= \case
+            VRight vi -> do
+              forM_ (_viPostRemove =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 15
+
+  rmStack' tv =
+    runRm runAppState (do
+        liftE $
+          rmStackVer tv
+        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+        pure (getVersionInfo tv Stack dls)
+      )
+      >>= \case
+            VRight vi -> do
+              forM_ (_viPostRemove =<< vi) $ \msg ->
+                runLogger $ logInfo msg
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 15
+

app/ghcup/GHCup/OptParse/Set.hs

@@ -0,0 +1,349 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Set where
+
+
+
+
+import           GHCup.OptParse.Common
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Either
+import           Data.Functor
+import           Data.Maybe
+import           Data.Versions           hiding ( str )
+import           GHC.Unicode
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Data.Bifunctor (second)
+import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data SetCommand = SetGHC SetOptions
+                | SetCabal SetOptions
+                | SetHLS SetOptions
+                | SetStack SetOptions
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data SetOptions = SetOptions
+  { sToolVer :: SetToolVersion
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+setParser :: Parser (Either SetCommand SetOptions)
+setParser =
+  (Left <$> subparser
+      (  command
+          "ghc"
+          (   SetGHC
+          <$> info
+                (setOpts (Just GHC) <**> helper)
+                (  progDesc "Set GHC version"
+                <> footerDoc (Just $ text setGHCFooter)
+                )
+          )
+      <> command
+           "cabal"
+           (   SetCabal
+           <$> info
+                 (setOpts (Just Cabal) <**> helper)
+                 (  progDesc "Set Cabal version"
+                 <> footerDoc (Just $ text setCabalFooter)
+                 )
+           )
+      <> command
+           "hls"
+           (   SetHLS
+           <$> info
+                 (setOpts (Just HLS) <**> helper)
+                 (  progDesc "Set haskell-language-server version"
+                 <> footerDoc (Just $ text setHLSFooter)
+                 )
+           )
+      <> command
+           "stack"
+           (   SetStack
+           <$> info
+                 (setOpts (Just Stack) <**> helper)
+                 (  progDesc "Set stack version"
+                 <> footerDoc (Just $ text setStackFooter)
+                 )
+           )
+      )
+    )
+    <|> (Right <$> setOpts Nothing)
+ where
+  setGHCFooter :: String
+  setGHCFooter = [s|Discussion:
+    Sets the the current GHC version by creating non-versioned
+    symlinks for all ghc binaries of the specified version in
+    "~/.ghcup/bin/<binary>".|]
+
+  setCabalFooter :: String
+  setCabalFooter = [s|Discussion:
+    Sets the the current Cabal version.|]
+
+  setStackFooter :: String
+  setStackFooter = [s|Discussion:
+    Sets the the current Stack version.|]
+
+  setHLSFooter :: String
+  setHLSFooter = [s|Discussion:
+    Sets the the current haskell-language-server version.|]
+
+
+setOpts :: Maybe Tool -> Parser SetOptions
+setOpts tool = SetOptions <$>
+    (fromMaybe SetRecommended <$>
+      optional (setVersionArgument (Just ListInstalled) tool))
+
+setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
+setVersionArgument criteria tool =
+  argument (eitherReader setEither)
+    (metavar "VERSION|TAG|next"
+    <> completer (tagCompleter (fromMaybe GHC tool) ["next"])
+    <> foldMap (completer . versionCompleter criteria) tool)
+ where
+  setEither s' =
+        parseSet s'
+    <|> second SetToolTag (tagEither s')
+    <|> second SetToolVersion (tVersionEither s')
+  parseSet s' = case fmap toLower s' of
+                  "next" -> Right SetNext
+                  other  -> Left $ "Unknown tag/version " <> other
+
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+setFooter :: String
+setFooter = [s|Discussion:
+  Sets the currently active GHC or cabal version. When no command is given,
+  defaults to setting GHC with the specified version/tag (if no tag
+  is given, sets GHC to 'recommended' version).
+  It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type SetGHCEffects = '[ FileDoesNotExistError
+                   , NotInstalled
+                   , TagNotFound
+                   , NextVerNotFound
+                   , NoToolVersionSet]
+
+runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
+          -> Excepts SetGHCEffects (ReaderT env m) a
+          -> m (VEither SetGHCEffects a)
+runSetGHC runAppState =
+    runAppState
+    . runE
+      @SetGHCEffects
+
+
+type SetCabalEffects = '[ NotInstalled
+                        , TagNotFound
+                        , NextVerNotFound
+                        , NoToolVersionSet]
+
+runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
+            -> Excepts SetCabalEffects (ReaderT env m) a
+            -> m (VEither SetCabalEffects a)
+runSetCabal runAppState =
+    runAppState
+    . runE
+      @SetCabalEffects
+
+
+type SetHLSEffects = '[ NotInstalled
+                      , TagNotFound
+                      , NextVerNotFound
+                      , NoToolVersionSet]
+
+runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
+          -> Excepts SetHLSEffects (ReaderT env m) a
+          -> m (VEither SetHLSEffects a)
+runSetHLS runAppState =
+    runAppState
+    . runE
+      @SetHLSEffects
+
+
+type SetStackEffects = '[ NotInstalled
+                        , TagNotFound
+                        , NextVerNotFound
+                        , NoToolVersionSet]
+
+runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
+            -> Excepts SetStackEffects (ReaderT env m) a
+            -> m (VEither SetStackEffects a)
+runSetStack runAppState =
+    runAppState
+    . runE
+      @SetStackEffects
+
+
+
+    -------------------
+    --[ Entrypoints ]--
+    -------------------
+
+
+set :: forall m env.
+       ( Monad m
+       , MonadMask m
+       , MonadUnliftIO m
+       , MonadFail m
+       , HasDirs env
+       , HasLog env
+       )
+    => Either SetCommand SetOptions
+    -> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
+        -> m (VEither eff GHCTargetVersion))
+    -> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
+        -> m (VEither eff GHCTargetVersion))
+    -> (ReaderT LeanAppState m () -> m ())
+    -> m ExitCode
+set setCommand runAppState runLeanAppState runLogger = case setCommand of
+  (Right sopts) -> do
+    runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
+    setGHC' sopts
+  (Left (SetGHC sopts)) -> setGHC' sopts
+  (Left (SetCabal sopts)) -> setCabal' sopts
+  (Left (SetHLS sopts)) -> setHLS' sopts
+  (Left (SetStack sopts)) -> setStack' sopts
+
+ where
+  setGHC' :: SetOptions
+          -> m ExitCode
+  setGHC' SetOptions{ sToolVer } =
+    case sToolVer of
+      (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)
+      _ -> runSetGHC runAppState (do
+          v <- liftE $ fst <$> fromVersion' sToolVer GHC
+          liftE $ setGHC v SetGHCOnly
+        )
+      >>= \case
+            VRight GHCTargetVersion{..} -> do
+              runLogger
+                $ logInfo $
+                    "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
+              pure ExitSuccess
+            VLeft e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 5
+
+
+  setCabal' :: SetOptions
+            -> m ExitCode
+  setCabal' SetOptions{ sToolVer } =
+    case sToolVer of
+      (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)
+      _ -> runSetCabal runAppState (do
+          v <- liftE $ fst <$> fromVersion' sToolVer Cabal
+          liftE $ setCabal (_tvVersion v)
+          pure v
+        )
+      >>= \case
+            VRight GHCTargetVersion{..} -> do
+              runLogger
+                $ logInfo $
+                    "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 14
+
+  setHLS' :: SetOptions
+          -> m ExitCode
+  setHLS' SetOptions{ sToolVer } =
+    case sToolVer of
+      (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)
+      _ -> runSetHLS runAppState (do
+          v <- liftE $ fst <$> fromVersion' sToolVer HLS
+          liftE $ setHLS (_tvVersion v)
+          pure v
+        )
+      >>= \case
+            VRight GHCTargetVersion{..} -> do
+              runLogger
+                $ logInfo $
+                    "HLS " <> prettyVer _tvVersion <> " successfully set as default version"
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 14
+
+
+  setStack' :: SetOptions
+            -> m ExitCode
+  setStack' SetOptions{ sToolVer } =
+    case sToolVer of
+      (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)
+      _ -> runSetStack runAppState (do
+            v <- liftE $ fst <$> fromVersion' sToolVer Stack
+            liftE $ setStack (_tvVersion v)
+            pure v
+          )
+      >>= \case
+            VRight GHCTargetVersion{..} -> do
+              runLogger
+                $ logInfo $
+                    "Stack " <> prettyVer _tvVersion <> " successfully set as default version"
+              pure ExitSuccess
+            VLeft  e -> do
+              runLogger $ logError $ T.pack $ prettyShow e
+              pure $ ExitFailure 14

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.ToolRequirements where
+
+
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
+import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
+import GHCup.Platform
+import GHCup.Utils.Prelude
+import GHCup.Requirements
+import System.IO
+
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoToolRequirements ]
+
+
+runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
+                    -> Excepts ToolRequirementsEffects (ReaderT env m) a
+                    -> m (VEither ToolRequirementsEffects a)
+runToolRequirements runAppState =
+    runAppState
+    . runE
+      @ToolRequirementsEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+toolRequirements :: ( Monad m
+                    , MonadMask m
+                    , MonadUnliftIO m
+                    , MonadFail m
+                    , Alternative m
+                    )
+                 => (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))
+                 -> (ReaderT LeanAppState m () -> m ())
+                 -> m ExitCode
+toolRequirements runAppState runLogger = runToolRequirements runAppState (do
+    GHCupInfo { .. } <- lift getGHCupInfo
+    platform' <- liftE getPlatform
+    req      <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements
+    liftIO $ T.hPutStr stdout (prettyRequirements req)
+  )
+    >>= \case
+          VRight _ -> pure ExitSuccess
+          VLeft  e -> do
+            runLogger $ logError $ T.pack $ prettyShow e
+            pure $ ExitFailure 12

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.UnSet where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data UnsetCommand = UnsetGHC   UnsetOptions
+                  | UnsetCabal UnsetOptions
+                  | UnsetHLS   UnsetOptions
+                  | UnsetStack UnsetOptions
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data UnsetOptions = UnsetOptions
+  { sToolVer :: Maybe T.Text -- target platform triple
+  }
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+unsetParser :: Parser UnsetCommand
+unsetParser =
+  subparser
+      (  command
+          "ghc"
+          (   UnsetGHC
+          <$> info
+                (unsetOpts <**> helper)
+                (  progDesc "Unset GHC version"
+                <> footerDoc (Just $ text unsetGHCFooter)
+                )
+          )
+      <> command
+           "cabal"
+           (   UnsetCabal
+           <$> info
+                (unsetOpts <**> helper)
+                 (  progDesc "Unset Cabal version"
+                 <> footerDoc (Just $ text unsetCabalFooter)
+                 )
+           )
+      <> command
+           "hls"
+           (   UnsetHLS
+           <$> info
+                 (unsetOpts <**> helper)
+                 (  progDesc "Unset haskell-language-server version"
+                 <> footerDoc (Just $ text unsetHLSFooter)
+                 )
+           )
+      <> command
+           "stack"
+           (   UnsetStack
+           <$> info
+                 (unsetOpts <**> helper)
+                 (  progDesc "Unset stack version"
+                 <> footerDoc (Just $ text unsetStackFooter)
+                 )
+           )
+      )
+ where
+  unsetGHCFooter :: String
+  unsetGHCFooter = [s|Discussion:
+    Unsets the the current GHC version. That means there won't
+    be a ~/.ghcup/bin/ghc anymore.|]
+
+  unsetCabalFooter :: String
+  unsetCabalFooter = [s|Discussion:
+    Unsets the the current Cabal version.|]
+
+  unsetStackFooter :: String
+  unsetStackFooter = [s|Discussion:
+    Unsets the the current Stack version.|]
+
+  unsetHLSFooter :: String
+  unsetHLSFooter = [s|Discussion:
+    Unsets the the current haskell-language-server version.|]
+
+
+unsetOpts :: Parser UnsetOptions
+unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE"))
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+unsetFooter :: String
+unsetFooter = [s|Discussion:
+  Unsets the currently active GHC or cabal version.|]
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type UnsetEffects = '[ NotInstalled ]
+
+
+runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
+            -> Excepts UnsetEffects (ReaderT env m) a
+            -> m (VEither UnsetEffects a)
+runUnsetGHC runLeanAppState =
+    runLeanAppState
+    . runE
+      @UnsetEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+unset :: ( Monad m
+         , MonadMask m
+         , MonadUnliftIO m
+         , MonadFail m
+         , HasDirs env
+         , HasLog env
+         )
+      => UnsetCommand
+      -> (ReaderT env m (VEither UnsetEffects ())
+          -> m (VEither UnsetEffects ()))
+      -> (ReaderT LeanAppState m () -> m ())
+      -> m ExitCode
+unset unsetCommand runLeanAppState runLogger = case unsetCommand of
+  (UnsetGHC (UnsetOptions triple)) -> runUnsetGHC runLeanAppState (unsetGHC triple)
+        >>= \case
+              VRight _ -> do
+                runLogger $ logInfo "GHC successfully unset"
+                pure ExitSuccess
+              VLeft  e -> do
+                runLogger $ logError $ T.pack $ prettyShow e
+                pure $ ExitFailure 14
+  (UnsetCabal (UnsetOptions _)) -> do
+    void $ runLeanAppState (VRight <$> unsetCabal)
+    runLogger $ logInfo "Cabal successfully unset"
+    pure ExitSuccess
+  (UnsetHLS (UnsetOptions _)) -> do
+    void $ runLeanAppState (VRight <$> unsetHLS)
+    runLogger $ logInfo "HLS successfully unset"
+    pure ExitSuccess
+  (UnsetStack (UnsetOptions _)) -> do
+    void $ runLeanAppState (VRight <$> unsetStack)
+    runLogger $ logInfo "Stack successfully unset"
+    pure ExitSuccess

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Upgrade where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Logger
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import System.Environment
+import GHCup.Utils
+import System.FilePath
+import GHCup.Types.Optics
+import Data.Versions         hiding (str)
+
+
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data UpgradeOpts = UpgradeInplace
+                 | UpgradeAt FilePath
+                 | UpgradeGHCupDir
+                 deriving Show
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+upgradeOptsP :: Parser UpgradeOpts
+upgradeOptsP =
+  flag'
+      UpgradeInplace
+      (short 'i' <> long "inplace" <> help
+        "Upgrade ghcup in-place (wherever it's at)"
+      )
+    <|> (   UpgradeAt
+        <$> option
+              str
+              (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
+                "Absolute filepath to write ghcup into"
+              )
+        )
+    <|> pure UpgradeGHCupDir
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type UpgradeEffects = '[ DigestError
+                       , GPGError
+                       , NoDownload
+                       , NoUpdate
+                       , FileDoesNotExistError
+                       , CopyError
+                       , DownloadFailed
+                       ]
+
+
+runUpgrade :: MonadUnliftIO m
+           => (ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
+           -> Excepts UpgradeEffects (ResourceT (ReaderT AppState m)) a
+           -> m (VEither UpgradeEffects a)
+runUpgrade runAppState =
+  runAppState
+  . runResourceT
+  . runE
+    @UpgradeEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+upgrade :: ( Monad m
+         , MonadMask m
+         , MonadUnliftIO m
+         , MonadFail m
+         )
+        => UpgradeOpts
+        -> Bool
+        -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
+        -> (ReaderT LeanAppState m () -> m ())
+        -> m ExitCode
+upgrade uOpts force' runAppState runLogger = do
+  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
+  target <- case uOpts of
+    UpgradeInplace  -> Just <$> liftIO getExecutablePath
+    (UpgradeAt p)   -> pure $ Just p
+    UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
+
+  runUpgrade runAppState (do
+    v' <- liftE $ upgradeGHCup target force'
+    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+    pure (v', dls)
+    ) >>= \case
+      VRight (v', dls) -> do
+        let pretty_v = prettyVer v'
+        let vi = fromJust $ snd <$> getLatest dls GHCup
+        runLogger $ logInfo $
+          "Successfully upgraded GHCup to version " <> pretty_v
+        forM_ (_viPostInstall vi) $ \msg ->
+          runLogger $ logInfo msg
+        pure ExitSuccess
+      VLeft (V NoUpdate) -> do
+        runLogger $ logWarn "No GHCup update available"
+        pure ExitSuccess
+      VLeft e -> do
+        runLogger $ logError $ T.pack $ prettyShow e
+        pure $ ExitFailure 11

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -0,0 +1,319 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHCup.OptParse.Whereis where
+
+
+
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.OptParse.Common
+import           GHCup.Types
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
+
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+
+import qualified Data.Text                     as T
+import Control.Exception.Safe (MonadMask)
+import System.FilePath (takeDirectory)
+import GHCup.Types.Optics
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
+                    | WhereisBaseDir
+                    | WhereisBinDir
+                    | WhereisCacheDir
+                    | WhereisLogsDir
+                    | WhereisConfDir
+
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data WhereisOptions = WhereisOptions {
+   directory :: Bool
+}
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+          
+whereisP :: Parser WhereisCommand
+whereisP = subparser
+  (commandGroup "Tools locations:" <> 
+    command
+      "ghc"
+      (WhereisTool GHC <$> info
+        ( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
+        ( progDesc "Get GHC location"
+        <> footerDoc (Just $ text whereisGHCFooter ))
+      )
+      <>
+     command
+      "cabal"
+      (WhereisTool Cabal <$> info
+        ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )
+        ( progDesc "Get cabal location"
+        <> footerDoc (Just $ text whereisCabalFooter ))
+      )
+      <>
+     command
+      "hls"
+      (WhereisTool HLS <$> info
+        ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )
+        ( progDesc "Get HLS location"
+        <> footerDoc (Just $ text whereisHLSFooter ))
+      )
+      <>
+     command
+      "stack"
+      (WhereisTool Stack <$> info
+        ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )
+        ( progDesc "Get stack location"
+        <> footerDoc (Just $ text whereisStackFooter ))
+      )
+      <>
+     command
+      "ghcup"
+      (WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
+    ) <|> subparser ( commandGroup "Directory locations:"
+      <>
+     command
+      "basedir"
+      (info (pure WhereisBaseDir <**> helper)
+            ( progDesc "Get ghcup base directory location" )
+      )
+      <>
+     command
+      "bindir"
+      (info (pure WhereisBinDir <**> helper)
+            ( progDesc "Get ghcup binary directory location" )
+      )
+      <>
+     command
+      "cachedir"
+      (info (pure WhereisCacheDir <**> helper)
+            ( progDesc "Get ghcup cache directory location" )
+      )
+      <>
+     command
+      "logsdir"
+      (info (pure WhereisLogsDir <**> helper)
+            ( progDesc "Get ghcup logs directory location" )
+      )
+      <>
+     command
+      "confdir"
+      (info (pure WhereisConfDir <**> helper)
+            ( progDesc "Get ghcup config directory location" )
+      )
+  )
+ where
+  whereisGHCFooter = [s|Discussion:
+  Finds the location of a GHC executable, which usually resides in
+  a self-contained "~/.ghcup/ghc/<ghcver>" directory.
+
+Examples:
+  # outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
+  ghcup whereis ghc 8.10.5
+  # outputs ~/.ghcup/ghc/8.10.5/bin/
+  ghcup whereis --directory ghc 8.10.5 |]
+
+  whereisCabalFooter = [s|Discussion:
+  Finds the location of a Cabal executable, which usually resides in
+  "~/.ghcup/bin/".
+
+Examples:
+  # outputs ~/.ghcup/bin/cabal-3.4.0.0
+  ghcup whereis cabal 3.4.0.0
+  # outputs ~/.ghcup/bin
+  ghcup whereis --directory cabal 3.4.0.0|]
+
+  whereisHLSFooter = [s|Discussion:
+  Finds the location of a HLS executable, which usually resides in
+  "~/.ghcup/bin/".
+
+Examples:
+  # outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
+  ghcup whereis hls 1.2.0
+  # outputs ~/.ghcup/bin/
+  ghcup whereis --directory hls 1.2.0|]
+
+  whereisStackFooter = [s|Discussion:
+  Finds the location of a stack executable, which usually resides in
+  "~/.ghcup/bin/".
+
+Examples:
+  # outputs ~/.ghcup/bin/stack-2.7.1
+  ghcup whereis stack 2.7.1
+  # outputs ~/.ghcup/bin/
+  ghcup whereis --directory stack 2.7.1|]
+
+
+
+    --------------
+    --[ Footer ]--
+    --------------
+
+
+whereisFooter :: String
+whereisFooter = [s|Discussion:
+  Finds the location of a tool. For GHC, this is the ghc binary, that
+  usually resides in a self-contained "~/.ghcup/ghc/<ghcver>" directory.
+  For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
+
+Examples:
+  # outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
+  ghcup whereis ghc 8.10.5
+  # outputs ~/.ghcup/ghc/8.10.5/bin/
+  ghcup whereis --directory ghc 8.10.5
+  # outputs ~/.ghcup/bin/cabal-3.4.0.0
+  ghcup whereis cabal 3.4.0.0
+  # outputs ~/.ghcup/bin/
+  ghcup whereis --directory cabal 3.4.0.0|]
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type WhereisEffects = '[ NotInstalled
+                , NoToolVersionSet
+                , NextVerNotFound
+                , TagNotFound
+                ]
+
+
+runLeanWhereIs :: (MonadUnliftIO m, MonadIO m)
+               => LeanAppState
+               -> Excepts WhereisEffects (ReaderT LeanAppState m) a
+               -> m (VEither WhereisEffects a)
+runLeanWhereIs leanAppstate =
+    -- Don't use runLeanAppState here, which is disabled on windows.
+    -- This is the only command on all platforms that doesn't need full appstate.
+    flip runReaderT leanAppstate
+    . runE
+      @WhereisEffects
+
+
+runWhereIs :: (MonadUnliftIO m, MonadIO m)
+           => (ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
+           -> Excepts WhereisEffects (ReaderT AppState m) a
+           -> m (VEither WhereisEffects a)
+runWhereIs runAppState =
+    runAppState
+    . runE
+      @WhereisEffects
+
+
+
+    ------------------
+    --[ Entrypoint ]--
+    ------------------
+
+
+
+whereis :: ( Monad m
+         , MonadMask m
+         , MonadUnliftIO m
+         , MonadFail m
+         )
+      => WhereisCommand
+      -> WhereisOptions
+      -> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
+      -> LeanAppState
+      -> (ReaderT LeanAppState m () -> m ())
+      -> m ExitCode
+whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
+  Dirs{ .. }  <- runReaderT getDirs leanAppstate
+  case (whereisCommand, whereisOptions) of
+    (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
+      runLeanWhereIs leanAppstate (do
+        loc <- liftE $ whereIsTool tool v
+        if directory
+        then pure $ takeDirectory loc
+        else pure loc
+        )
+        >>= \case
+              VRight r -> do
+                liftIO $ putStr r
+                pure ExitSuccess
+              VLeft e -> do
+                runLogger $ logError $ T.pack $ prettyShow e
+                pure $ ExitFailure 30
+
+    (WhereisTool tool whereVer, WhereisOptions{..}) -> do
+      runWhereIs runAppState (do
+        (v, _) <- liftE $ fromVersion whereVer tool
+        loc <- liftE $ whereIsTool tool v
+        if directory
+        then pure $ takeDirectory loc
+        else pure loc
+        )
+        >>= \case
+              VRight r -> do
+                liftIO $ putStr r
+                pure ExitSuccess
+              VLeft e -> do
+                runLogger $ logError $ T.pack $ prettyShow e
+                pure $ ExitFailure 30
+
+    (WhereisBaseDir, _) -> do
+      liftIO $ putStr baseDir
+      pure ExitSuccess
+
+    (WhereisBinDir, _) -> do
+      liftIO $ putStr binDir
+      pure ExitSuccess
+
+    (WhereisCacheDir, _) -> do
+      liftIO $ putStr cacheDir
+      pure ExitSuccess
+
+    (WhereisLogsDir, _) -> do
+      liftIO $ putStr logsDir
+      pure ExitSuccess
+
+    (WhereisConfDir, _) -> do
+      liftIO $ putStr confDir
+      pure ExitSuccess

ghcup.cabal

@@ -172,6 +172,23 @@ library
 
 executable ghcup
   main-is:            Main.hs
+  other-modules:      GHCup.OptParse.Install
+                      GHCup.OptParse.Common
+                      GHCup.OptParse.Set
+                      GHCup.OptParse.UnSet
+                      GHCup.OptParse.Rm
+                      GHCup.OptParse.Compile
+                      GHCup.OptParse.Config
+                      GHCup.OptParse.Whereis
+                      GHCup.OptParse.List
+                      GHCup.OptParse.DInfo
+                      GHCup.OptParse.Upgrade
+                      GHCup.OptParse.ToolRequirements
+                      GHCup.OptParse.ChangeLog
+                      GHCup.OptParse.Nuke
+                      GHCup.OptParse.Prefetch
+                      GHCup.OptParse.GC
+                      GHCup.OptParse
   hs-source-dirs:     app/ghcup
   default-language:   Haskell2010
   default-extensions: