ghcup-hs/app/ghcup/Main.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}


module Main where

#if defined(BRICK)
import           BrickMain                    ( brickMain )
#endif

import           GHCup
import           GHCup.Download
import           GHCup.Errors
import           GHCup.Platform
import           GHCup.Requirements
import           GHCup.Types
import           GHCup.Types.Optics
import           GHCup.Utils
import           GHCup.Utils.File
import           GHCup.Utils.Logger
import           GHCup.Utils.MegaParsec
import           GHCup.Utils.Prelude
import           GHCup.Utils.String.QQ
import           GHCup.Version

#if !defined(TAR)
import           Codec.Archive
#endif
import           Control.Concurrent
import           Control.DeepSeq                ( force )
import           Control.Exception              ( evaluate )
import           Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             ( MonadFail )
#endif
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.Bifunctor
import           Data.Char
import           Data.Either
import           Data.Functor
import           Data.List                      ( intercalate, nub, sort, sortBy )
import           Data.List.NonEmpty             (NonEmpty ((:|)))
import           Data.Maybe
import           Data.String.Interpolate
import           Data.Text                      ( Text )
import           Data.Versions           hiding ( str )
import           Data.Void
import           GHC.IO.Encoding
import           Haskus.Utils.Variant.Excepts
import           Language.Haskell.TH
import           Options.Applicative     hiding ( style )
import           Options.Applicative.Help.Pretty ( text )
import           Prelude                 hiding ( appendFile )
import           Safe
import           System.Console.Pretty   hiding ( color )
import qualified System.Console.Pretty         as Pretty
import           System.Environment
import           System.Exit
import           System.FilePath
import           System.IO               hiding ( appendFile )
import           Text.Read               hiding ( lift )
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
import           URI.ByteString

import qualified Data.ByteString               as B
import qualified Data.ByteString.UTF8          as UTF8
import qualified Data.Map.Strict               as M
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as T
import qualified Data.Text.Encoding            as E
import qualified Text.Megaparsec               as MP
import qualified Text.Megaparsec.Char          as MPC



data Options = Options
  {
  -- global options
    optVerbose   :: Maybe Bool
  , optCache     :: Maybe Bool
  , optUrlSource :: Maybe URI
  , optNoVerify  :: Maybe Bool
  , optKeepDirs  :: Maybe KeepDirs
  , optsDownloader :: Maybe Downloader
  -- commands
  , optCommand   :: Command
  }

data Command
  = Install (Either InstallCommand InstallOptions)
  | InstallCabalLegacy InstallOptions
  | Set (Either SetCommand SetOptions)
  | List ListOptions
  | Rm (Either RmCommand RmOptions)
  | DInfo
  | Compile CompileCommand
  | Whereis WhereisOptions WhereisCommand
  | Upgrade UpgradeOpts Bool
  | ToolRequirements
  | ChangeLog ChangeLogOptions
  | Nuke
#if defined(BRICK)
  | Interactive
#endif

data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
                 | ToolTag Tag

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


data InstallCommand = InstallGHC InstallOptions
                    | InstallCabal InstallOptions
                    | InstallHLS InstallOptions
                    | InstallStack InstallOptions

data InstallOptions = InstallOptions
  { instVer      :: Maybe ToolVersion
  , instPlatform :: Maybe PlatformRequest
  , instBindist  :: Maybe URI
  , instSet      :: Bool
  }

data SetCommand = SetGHC SetOptions
                | SetCabal SetOptions
                | SetHLS SetOptions
                | SetStack SetOptions

-- a superset of ToolVersion
data SetToolVersion = SetToolVersion GHCTargetVersion
                    | SetToolTag Tag
                    | SetRecommended
                    | SetNext

data SetOptions = SetOptions
  { sToolVer :: SetToolVersion
  }

data ListOptions = ListOptions
  { loTool     :: Maybe Tool
  , lCriteria  :: Maybe ListCriteria
  , lRawFormat :: Bool
  }

data RmCommand = RmGHC RmOptions
               | RmCabal Version
               | RmHLS Version
               | RmStack Version

data RmOptions = RmOptions
  { ghcVer :: GHCTargetVersion
  }


data CompileCommand = CompileGHC GHCCompileOptions

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
  }

data UpgradeOpts = UpgradeInplace
                 | UpgradeAt FilePath
                 | UpgradeGHCupDir
                 deriving Show

data ChangeLogOptions = ChangeLogOptions
  { clOpen    :: Bool
  , clTool    :: Maybe Tool
  , clToolVer :: Maybe ToolVersion
  }


data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)

data WhereisOptions = WhereisOptions {
   directory :: Bool
}


-- 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


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
          ))
    <*> 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"
                <> footerDoc (Just $ text installToolFooter)
                )
          )
      <> command
           "set"
           (info
             (Set <$> setParser <**> helper)
             (  progDesc "Set currently active GHC/cabal version"
             <> footerDoc (Just $ text setFooter)
             )
           )
      <> command
           "rm"
           (info
             (Rm <$> rmParser <**> helper)
             (  progDesc "Remove a GHC/cabal/HLS 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 ))
           )
      <> 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)
                  )
               )
          <> 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:"
          )

 where
  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).|]

  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).|]

  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).|]

  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.|]

  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|]


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.|]


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-languge-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 -> InstallOptions v p u b)
    <$> 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"
          )


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))

listOpts :: Parser ListOptions
listOpts =
  ListOptions
    <$> optional
          (option
            (eitherReader toolParser)
            (short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
              "Tool to list versions for. Default is all"
            )
          )
    <*> optional
          (option
            (eitherReader criteriaParser)
            (  short 'c'
            <> long "show-criteria"
            <> metavar "<installed|set>"
            <> help "Show only installed or set tool versions"
            )
          )
    <*> switch
          (short 'r' <> long "raw-format" <> help "More machine-parsable format"
          )


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


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)

compileP :: Parser CompileCommand
compileP = subparser
  (  command
      "ghc"
      (   CompileGHC
      <$> info
            (ghcCompileOpts <**> helper)
            (  progDesc "Compile GHC from source"
            <> footerDoc (Just $ text compileFooter)
            )
      )
  )
 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|]


whereisP :: Parser WhereisCommand
whereisP = subparser
  (  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" ))
  )
 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|]


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 (applied in order, uses -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'"
            )
          )


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")

-- | same as toolVersionParser, except as an argument.
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument criteria tool =
  argument (eitherReader toolVersionEither)
    (metavar "VERSION|TAG"
    <> completer (tagCompleter (fromMaybe GHC tool) [])
    <> foldMap (completer . versionCompleter criteria) 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 [i|Unknown tag/version #{other}|]


versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)


tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
  dirs' <- liftIO getAllDirs
  let loggerConfig = LoggerConfig
        { lcPrintDebug = False
        , colorOutter  = mempty
        , rawOutter    = mempty
        }
  let runLogger = myLoggerT loggerConfig
  mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
  case mGhcUpInfo of
    VRight ghcupInfo -> do
      let allTags = filter (\t -> t /= Old)
            $ join
            $ 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
        , colorOutter  = mempty
        , rawOutter    = mempty
        }
  let runLogger = myLoggerT loggerConfig
  mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
  mpFreq <- runLogger . runE $ platformRequest
  forFold mpFreq $ \pfreq ->
    forFold mGhcUpInfo $ \ghcupInfo -> do
      let appState = AppState
            (Settings True False Never Curl False GHCupURL)
            dirs'
            defaultKeyBindings
            ghcupInfo
            pfreq

          runEnv = runLogger . flip runReaderT appState

      installedVersions <- runEnv $ listVersions (Just tool) criteria
      return $ T.unpack . prettyVer . lVer <$> installedVersions


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)


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 [i|Invalid PVP version for base #{ver'}|]
  other         -> Left [i|Unknown tag #{other}|]


tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
  first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack


toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
  second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')


toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc"   = Right GHC
              | t == T.pack "cabal" = Right Cabal
              | 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
                  | otherwise               = Left ("Unknown criteria: " <> s')
  where t = T.toLower (T.pack s')


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')


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'
    [ (\a mv -> PlatformRequest a FreeBSD mv)
    <$> (archP <* MP.chunk "-")
    <*> (  MP.chunk "portbld"
        *> (   MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
           <|> pure Nothing
           )
        <* MP.chunk "-freebsd"
        )
    , (\a mv -> PlatformRequest a Darwin mv)
    <$> (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


toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do
  userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
    VRight r -> pure r
    VLeft (V (JSONDecodeError e)) -> do
      B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
      pure defaultUserSettings
    _ -> do
      die "Unexpected error!"
  pure $ mergeConf options userConf
 where
   mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
   mergeConf Options{..} UserSettings{..} =
     let cache       = fromMaybe (fromMaybe False uCache) optCache
         noVerify    = fromMaybe (fromMaybe False uNoVerify) optNoVerify
         verbose     = fromMaybe (fromMaybe False uVerbose) optVerbose
         keepDirs    = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
         downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
         keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
         urlSource   = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
     in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
   defaultDownloader = Internal
#else
   defaultDownloader = Curl
#endif
   mergeKeys :: UserKeyBindings -> KeyBindings
   mergeKeys UserKeyBindings {..} =
     let KeyBindings {..} = defaultKeyBindings
     in KeyBindings {
           bUp = fromMaybe bUp kUp
         , bDown = fromMaybe bDown kDown
         , bQuit = fromMaybe bQuit kQuit
         , bInstall = fromMaybe bInstall kInstall
         , bUninstall = fromMaybe bUninstall kUninstall
         , bSet = fromMaybe bSet kSet
         , bChangelog = fromMaybe bChangelog kChangelog
         , bShowAllVersions = fromMaybe bShowAllVersions kShowAll
         , bShowAllTools = fromMaybe bShowAllTools kShowAllTools
         }


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



describe_result :: String
describe_result = $( LitE . StringL <$>
                     runIO (do
                             CapturedProcess{..} <-  do
                              dirs <- liftIO getAllDirs
                              let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
                              flip runReaderT settings $ executeOut "git" ["describe"] Nothing
                             case _exitCode of
                               ExitSuccess   -> pure . T.unpack . decUTF8Safe' $ _stdOut
                               ExitFailure _ -> pure numericVer
                     )
                   )


main :: IO ()
main = do
  -- https://gitlab.haskell.org/ghc/ghc/issues/8118
  setLocaleEncoding utf8

  void enableAnsiSupport

  let versionHelp = infoOption
        ( ("The GHCup Haskell installer, version " <>)
          (head . lines $ describe_result)
        )
        (long "version" <> help "Show version" <> hidden)
  let numericVersionHelp = infoOption
        numericVer
        (  long "numeric-version"
        <> help "Show the numeric version (for use in scripts)"
        <> hidden
        )
  let listCommands = infoOption
        "install set rm install-cabal list upgrade compile debug-info tool-requirements changelog"
        (  long "list-commands"
        <> help "List available commands for shell completion"
        <> internal
        )

  let main_footer = [s|Discussion:
  ghcup installs the Glasgow Haskell Compiler from the official
  release channels, enabling you to easily switch between different
  versions. It maintains a self-contained ~/.ghcup directory.

ENV variables:
  * TMPDIR: where ghcup does the work (unpacking, building, ...)
  * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
  * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories

Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]

  customExecParser
      (prefs showHelpOnError)
      (info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> listCommands)
            (footerDoc (Just $ text main_footer))
      )
    >>= \opt@Options {..} -> do
          dirs@Dirs{..} <- getAllDirs

          -- create ~/.ghcup dir
          ensureDirectories dirs

          (settings, keybindings) <- toSettings opt

          -- logger interpreter
          logfile <- initGHCupFileLogging logsDir
          let loggerConfig = LoggerConfig
                { lcPrintDebug = verbose settings
                , colorOutter  = B.hPut stderr
                , rawOutter    =
                    case optCommand of
                      Nuke -> \_ -> pure ()
                      _ -> B.appendFile logfile
                }
          let runLogger = myLoggerT loggerConfig
          let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }


          -------------------------
          -- Setting up appstate --
          -------------------------


          let leanAppstate = LeanAppState settings dirs keybindings
              appState = do
                pfreq <- (
                  runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
                  ) >>= \case
                          VRight r -> pure r
                          VLeft e -> do
                            runLogger
                              ($(logError) $ T.pack $ prettyShow e)
                            exitWith (ExitFailure 2)

                ghcupInfo <-
                  ( runLogger
                    . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
                    $ liftE
                    $ getDownloadsF settings dirs
                    )
                    >>= \case
                          VRight r -> pure r
                          VLeft  e -> do
                            runLogger
                              ($(logError) $ T.pack $ prettyShow e)
                            exitWith (ExitFailure 2)
                let s' = AppState settings dirs keybindings ghcupInfo pfreq

                lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
                  Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
                  Just _ -> pure ()

                -- TODO: always run for windows
                (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
                  VRight _ -> pure ()
                  VLeft e -> do
                    runLogger
                      ($(logError) $ T.pack $ prettyShow e)
                    exitWith (ExitFailure 30)
                pure s'


              runLeanAppState = flip runReaderT leanAppstate
              runAppState action' = do
                s' <- liftIO appState
                flip runReaderT s' action'
                  



          -------------------------
          -- Effect interpreters --
          -------------------------

          let runInstTool' appstate' mInstPlatform =
                runLogger
                  . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform)
                  . runResourceT
                  . runE
                    @'[ AlreadyInstalled
                      , UnknownArchive
#if !defined(TAR)
                      , ArchiveResult
#endif
                      , FileDoesNotExistError
                      , CopyError
                      , NoDownload
                      , NotInstalled
                      , BuildFailed
                      , TagNotFound
                      , DigestError
                      , DownloadFailed
                      , TarDirDoesNotExist
                      , NextVerNotFound
                      , NoToolVersionSet
                      ]

          let runInstTool mInstPlatform action' = do
                s' <- liftIO appState
                runInstTool' s' mInstPlatform action'

          let
            runLeanSetGHC =
              runLogger
                . runLeanAppState
                . runE
                  @'[ FileDoesNotExistError
                    , NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

            runSetGHC =
              runLogger
                . runAppState
                . runE
                  @'[ FileDoesNotExistError
                    , NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

          let
            runLeanSetCabal =
              runLogger
                . runLeanAppState
                . runE
                  @'[ NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

            runSetCabal =
              runLogger
                . runAppState
                . runE
                  @'[ NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

          let
            runSetHLS =
              runLogger
                . runAppState
                . runE
                  @'[ NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

            runLeanSetHLS =
              runLogger
                . runLeanAppState
                . runE
                  @'[ NotInstalled
                    , TagNotFound
                    , NextVerNotFound
                    , NoToolVersionSet
                    ]

          let runListGHC = runLogger . runAppState

          let runRm =
                runLogger . runAppState . runE @'[NotInstalled]

          let runDebugInfo =
                runLogger
                  . runAppState
                  . runE
                    @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]

          let runCompileGHC =
                runLogger
                  . runAppState
                  . runResourceT
                  . runE
                    @'[ AlreadyInstalled
                      , BuildFailed
                      , DigestError
                      , DownloadFailed
                      , GHCupSetError
                      , NoDownload
                      , NotFoundInPATH
                      , PatchFailed
                      , UnknownArchive
                      , TarDirDoesNotExist
                      , NotInstalled
#if !defined(TAR)
                      , ArchiveResult
#endif
                      ]

          let
            runLeanWhereIs =
              runLogger
                . runLeanAppState
                . runE
                  @'[ NotInstalled
                    , NoToolVersionSet
                    , NextVerNotFound
                    , TagNotFound
                    ]

            runWhereIs =
              runLogger
                . runAppState
                . runE
                  @'[ NotInstalled
                    , NoToolVersionSet
                    , NextVerNotFound
                    , TagNotFound
                    ]

          let runUpgrade =
                runLogger
                  . runAppState
                  . runResourceT
                  . runE
                    @'[ DigestError
                      , NoDownload
                      , NoUpdate
                      , FileDoesNotExistError
                      , CopyError
                      , DownloadFailed
                      ]


          -----------------------
          -- Command functions --
          -----------------------

          let installGHC InstallOptions{..} =
                  (case instBindist of
                     Nothing -> runInstTool instPlatform $ do
                       (v, vi) <- liftE $ fromVersion instVer GHC
                       liftE $ installGHCBin (_tvVersion v)
                       when instSet $ void $ liftE $ setGHC v SetGHCOnly
                       pure vi
                     Just uri -> do
                       s' <- liftIO appState
                       runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
                         (v, vi) <- liftE $ fromVersion instVer GHC
                         liftE $ installGHCBindist
                           (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                           (_tvVersion v)
                         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)
                              [i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
                            pure ExitSuccess
                          VLeft err@(V (BuildFailed tmpdir _)) -> do
                            case keepDirs settings of
                              Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
                              _ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
    Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
    Make sure to clean up #{tmpdir} afterwards.|])
                            pure $ ExitFailure 3
                          VLeft e -> do
                            runLogger $ do
                              $(logError) $ T.pack $ prettyShow e
                              $(logError) [i|Also check the logs in #{logsDir}|]
                            pure $ ExitFailure 3


          let installCabal InstallOptions{..} =
                (case instBindist of
                   Nothing -> runInstTool instPlatform $ do
                     (v, vi) <- liftE $ fromVersion instVer Cabal
                     liftE $ installCabalBin (_tvVersion v)
                     pure vi
                   Just uri -> do
                     s' <- appState
                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                       (v, vi) <- liftE $ fromVersion instVer Cabal
                       liftE $ installCabalBindist
                           (DownloadInfo uri Nothing "")
                           (_tvVersion v)
                       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)
                            [i|Cabal ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal #{prettyVer v}' first|]
                          pure ExitSuccess
                        VLeft e -> do
                          runLogger $ do
                            $(logError) $ T.pack $ prettyShow e
                            $(logError) [i|Also check the logs in #{logsDir}|]
                          pure $ ExitFailure 4

          let installHLS InstallOptions{..} =
                (case instBindist of
                   Nothing -> runInstTool instPlatform $ do
                     (v, vi) <- liftE $ fromVersion instVer HLS
                     liftE $ installHLSBin (_tvVersion v)
                     pure vi
                   Just uri -> do
                     s' <- appState
                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                       (v, vi) <- liftE $ fromVersion instVer HLS
                       liftE $ installHLSBindist
                           (DownloadInfo uri Nothing "")
                           (_tvVersion v)
                       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)
                            [i|HLS ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls #{prettyVer v}' first|]
                          pure ExitSuccess
                        VLeft e -> do
                          runLogger $ do
                            $(logError) $ T.pack $ prettyShow e
                            $(logError) [i|Also check the logs in #{logsDir}|]
                          pure $ ExitFailure 4

          let installStack InstallOptions{..} =
                (case instBindist of
                   Nothing -> runInstTool instPlatform $ do
                     (v, vi) <- liftE $ fromVersion instVer Stack
                     liftE $ installStackBin (_tvVersion v)
                     pure vi
                   Just uri -> do
                     s' <- appState
                     runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
                       (v, vi) <- liftE $ fromVersion instVer Stack
                       liftE $ installStackBindist
                           (DownloadInfo uri Nothing "")
                           (_tvVersion v)
                       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)
                            [i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
                          pure ExitSuccess
                        VLeft e -> do
                          runLogger $ do
                            $(logError) $ T.pack $ prettyShow e
                            $(logError) [i|Also check the logs in #{logsDir}|]
                          pure $ ExitFailure 4


          let setGHC' SetOptions{ sToolVer } =
                case sToolVer of
                  (SetToolVersion v) -> runLeanSetGHC (liftE $ setGHC v SetGHCOnly >> pure v)
                  _ -> runSetGHC (do
                      v <- liftE $ fst <$> fromVersion' sToolVer GHC
                      liftE $ setGHC v SetGHCOnly
                    )
                  >>= \case
                        VRight GHCTargetVersion{..} -> do
                          runLogger
                            $ $(logInfo)
                                [i|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

          let setCabal' SetOptions{ sToolVer } =
                case sToolVer of
                  (SetToolVersion v) -> runLeanSetCabal (liftE $ setCabal (_tvVersion v) >> pure v)
                  _ -> runSetCabal (do
                      v <- liftE $ fst <$> fromVersion' sToolVer Cabal
                      liftE $ setCabal (_tvVersion v)
                      pure v
                    )
                  >>= \case
                        VRight GHCTargetVersion{..} -> do
                          runLogger
                            $ $(logInfo)
                                [i|Cabal #{prettyVer _tvVersion} successfully set as default version|]
                          pure ExitSuccess
                        VLeft  e -> do
                          runLogger $ $(logError) $ T.pack $ prettyShow e
                          pure $ ExitFailure 14

          let setHLS' SetOptions{ sToolVer } =
                case sToolVer of
                  (SetToolVersion v) -> runLeanSetHLS (liftE $ setHLS (_tvVersion v) >> pure v)
                  _ -> runSetHLS (do
                      v <- liftE $ fst <$> fromVersion' sToolVer HLS
                      liftE $ setHLS (_tvVersion v)
                      pure v
                    )
                  >>= \case
                        VRight GHCTargetVersion{..} -> do
                          runLogger
                            $ $(logInfo)
                                [i|HLS #{prettyVer _tvVersion} successfully set as default version|]
                          pure ExitSuccess
                        VLeft  e -> do
                          runLogger $ $(logError) $ T.pack $ prettyShow e
                          pure $ ExitFailure 14

          let setStack' SetOptions{ sToolVer } =
                case sToolVer of
                  (SetToolVersion v) -> runSetCabal (liftE $ setStack (_tvVersion v) >> pure v)
                  _ -> runSetCabal (do
                        v <- liftE $ fst <$> fromVersion' sToolVer Stack
                        liftE $ setStack (_tvVersion v)
                        pure v
                      )
                  >>= \case
                        VRight GHCTargetVersion{..} -> do
                          runLogger
                            $ $(logInfo)
                                [i|Stack #{prettyVer _tvVersion} successfully set as default version|]
                          pure ExitSuccess
                        VLeft  e -> do
                          runLogger $ $(logError) $ T.pack $ prettyShow e
                          pure $ ExitFailure 14

          let rmGHC' RmOptions{..} =
                runRm (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

          let rmCabal' tv =
                runRm (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

          let rmHLS' tv =
                runRm (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

          let rmStack' tv =
                runRm (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

          res <- case optCommand of
#if defined(BRICK)
            Interactive -> do
              liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess
#endif
            Install (Right iopts) -> do
              runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
              installGHC iopts
            Install (Left (InstallGHC iopts)) -> installGHC iopts
            Install (Left (InstallCabal iopts)) -> installCabal iopts
            Install (Left (InstallHLS iopts)) -> installHLS iopts
            Install (Left (InstallStack iopts)) -> installStack iopts
            InstallCabalLegacy iopts -> do
              runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
              installCabal iopts

            Set (Right sopts) -> do
              runLogger ($(logWarn) [i|This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.|])
              setGHC' sopts
            Set (Left (SetGHC sopts)) -> setGHC' sopts
            Set (Left (SetCabal sopts)) -> setCabal' sopts
            Set (Left (SetHLS sopts)) -> setHLS' sopts
            Set (Left (SetStack sopts)) -> setStack' sopts

            List ListOptions {..} ->
              runListGHC (do
                  l <- listVersions loTool lCriteria
                  liftIO $ printListResult lRawFormat l
                  pure ExitSuccess
                )

            Rm (Right rmopts) -> do
              runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
              rmGHC' rmopts
            Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
            Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
            Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
            Rm (Left (RmStack rmopts)) -> rmStack' rmopts

            DInfo ->
              do runDebugInfo $ liftE getDebugInfo
                >>= \case
                      VRight dinfo -> do
                        putStrLn $ prettyDebugInfo dinfo
                        pure ExitSuccess
                      VLeft e -> do
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 8

            Compile (CompileGHC GHCCompileOptions {..}) ->
              runCompileGHC (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
                GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                when setCompile $ void $ liftE $
                  setGHC targetVer SetGHCOnly
                pure vi
                )
                >>= \case
                      VRight vi -> do
                        runLogger $ $(logInfo)
                          "GHC successfully compiled and installed"
                        forM_ (_viPostInstall =<< vi) $ \msg ->
                          runLogger $ $(logInfo) msg
                        pure ExitSuccess
                      VLeft (V (AlreadyInstalled _ v)) -> do
                        runLogger $ $(logWarn)
                          [i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
                        pure ExitSuccess
                      VLeft err@(V (BuildFailed tmpdir _)) -> do
                        case keepDirs settings of
                          Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
                          _ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
                        pure $ ExitFailure 9
                      VLeft e -> do
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 9

            Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
              runLeanWhereIs (do
                loc <- liftE $ whereIsTool tool v
                if directory
                then pure $ takeDirectory loc
                else pure loc
                )
                >>= \case
                      VRight r -> do
                        putStr r
                        pure ExitSuccess
                      VLeft e -> do
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 30

            Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
              runWhereIs (do
                (v, _) <- liftE $ fromVersion whereVer tool
                loc <- liftE $ whereIsTool tool v
                if directory
                then pure $ takeDirectory loc
                else pure loc
                )
                >>= \case
                      VRight r -> do
                        putStr r
                        pure ExitSuccess
                      VLeft e -> do
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 30

            Upgrade uOpts force' -> do
              target <- case uOpts of
                UpgradeInplace  -> Just <$> liftIO getExecutablePath
                (UpgradeAt p)   -> pure $ Just p
                UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))

              runUpgrade (liftE $ upgradeGHCup target force') >>= \case
                VRight v' -> do
                  GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
                  let pretty_v = prettyVer v'
                  let vi = fromJust $ snd <$> getLatest dls GHCup
                  runLogger $ $(logInfo)
                    [i|Successfully upgraded GHCup to version #{pretty_v}|]
                  forM_ (_viPostInstall vi) $ \msg ->
                    runLogger $ $(logInfo) msg
                  pure ExitSuccess
                VLeft (V NoUpdate) -> do
                  runLogger $ $(logWarn) [i|No GHCup update available|]
                  pure ExitSuccess
                VLeft e -> do
                  runLogger $ $(logError) $ T.pack $ prettyShow e
                  pure $ ExitFailure 11

            ToolRequirements -> do
              s' <- appState
              flip runReaderT s'
                $ runLogger
                  (runE
                    @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
                  $ 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

            ChangeLog ChangeLogOptions{..} -> 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)
                      [i|Could not find ChangeLog for #{tool}, version #{either (T.unpack . prettyVer) 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
                      s' <- appState
                      flip runReaderT s' $
                        exec cmd
                             [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
                             Nothing
                             Nothing
                          >>= \case
                                Right _ -> pure ExitSuccess
                                Left  e -> runLogger ($(logError) [i|#{e}|])
                                  >> pure (ExitFailure 13)
                    else putStrLn uri' >> pure ExitSuccess

            Nuke ->
              runRm (do
                   s' <- liftIO appState
                   void $ liftIO $ evaluate $ force s'
                   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 $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
                                  forM_ leftOverFiles putStrLn
                                  pure ExitSuccess

                            VLeft e -> do
                              runLogger $ $(logError) $ T.pack $ prettyShow e
                              pure $ ExitFailure 15


          case res of
            ExitSuccess        -> pure ()
            ef@(ExitFailure _) -> exitWith ef


  pure ()

fromVersion :: ( MonadLogger m
               , 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' :: ( MonadLogger m
                , 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
  (\(x, y) -> (mkTVer x, Just y)) <$> 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
    Left _ -> pure (v, vi)
    Right (PVP (major' :|[minor'])) ->
      case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
        Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
        Nothing -> pure (v, vi)
    Right _ -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
  (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
  (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
  (\(x, y) -> (mkTVer x, Just y)) <$> 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 {..} -> _tvTarget == Nothing)
        $ 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


printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
  no_color <- isJust <$> lookupEnv "NO_COLOR"

  let
    color | raw || no_color = flip const
          | 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 . fmap) strWidth $ cols
      padded  = fmap (\xs -> zipWith padTo xs lengths) rows

  forM_ padded $ \row -> putStrLn $ intercalate " " 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


checkForUpdates :: ( MonadReader env m
                   , HasGHCupInfo env
                   , HasDirs env
                   , HasPlatformReq env
                   , MonadCatch m
                   , MonadLogger m
                   , MonadThrow m
                   , MonadIO m
                   , MonadFail m
                   , MonadLogger 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)
          [i|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)
            [i|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)
            [i|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)
            [i|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)
            [i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]


prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info
==========
GHCup base dir: #{diBaseDir}
GHCup bin dir: #{diBinDir}
GHCup GHC directory: #{diGHCDir}
GHCup cache directory: #{diCacheDir}
Architecture: #{prettyShow diArch}
Platform: #{prettyShow diPlatform}
Version: #{describe_result}|]