ghcup 0.1.19.5 → 0.1.20.0

raw patch · 98 files changed

+47426/−45532 lines, 98 filesdep +tastydep +tasty-hunitdep ~asyncdep ~basedep ~brickPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tasty, tasty-hunit

Dependency ranges changed: async, base, brick, deepseq, optparse-applicative, retry, template-haskell, text, time, unordered-containers, uri-bytestring, vector, versions, vty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−2
• app/ghcup/BrickMain.hs +56/−18
• app/ghcup/GHCup/OptParse.hs +0/−363
• app/ghcup/GHCup/OptParse/ChangeLog.hs +0/−148
• app/ghcup/GHCup/OptParse/Common.hs +0/−830
• app/ghcup/GHCup/OptParse/Compile.hs +0/−614
• app/ghcup/GHCup/OptParse/Config.hs +0/−261
• app/ghcup/GHCup/OptParse/DInfo.hs +0/−119
• app/ghcup/GHCup/OptParse/GC.hs +0/−142
• app/ghcup/GHCup/OptParse/Install.hs +0/−538
• app/ghcup/GHCup/OptParse/List.hs +0/−315
• app/ghcup/GHCup/OptParse/Nuke.hs +0/−98
• app/ghcup/GHCup/OptParse/Prefetch.hs +0/−220
• app/ghcup/GHCup/OptParse/Rm.hs +0/−231
• app/ghcup/GHCup/OptParse/Run.hs +0/−495
• app/ghcup/GHCup/OptParse/Set.hs +0/−343
• app/ghcup/GHCup/OptParse/Test.hs +0/−189
• app/ghcup/GHCup/OptParse/ToolRequirements.hs +0/−121
• app/ghcup/GHCup/OptParse/UnSet.hs +0/−204
• app/ghcup/GHCup/OptParse/Upgrade.hs +0/−155
• app/ghcup/GHCup/OptParse/Whereis.hs +0/−342
• app/ghcup/Main.hs +8/−9
• data/config.yaml +39/−30
• ghcup.cabal +132/−56
• lib-opt/GHCup/OptParse.hs +360/−0
• lib-opt/GHCup/OptParse/ChangeLog.hs +148/−0
• lib-opt/GHCup/OptParse/Common.hs +844/−0
• lib-opt/GHCup/OptParse/Compile.hs +621/−0
• lib-opt/GHCup/OptParse/Config.hs +240/−0
• lib-opt/GHCup/OptParse/DInfo.hs +119/−0
• lib-opt/GHCup/OptParse/GC.hs +142/−0
• lib-opt/GHCup/OptParse/Install.hs +543/−0
• lib-opt/GHCup/OptParse/List.hs +314/−0
• lib-opt/GHCup/OptParse/Nuke.hs +98/−0
• lib-opt/GHCup/OptParse/Prefetch.hs +224/−0
• lib-opt/GHCup/OptParse/Rm.hs +232/−0
• lib-opt/GHCup/OptParse/Run.hs +509/−0
• lib-opt/GHCup/OptParse/Set.hs +344/−0
• lib-opt/GHCup/OptParse/Test.hs +189/−0
• lib-opt/GHCup/OptParse/ToolRequirements.hs +121/−0
• lib-opt/GHCup/OptParse/UnSet.hs +212/−0
• lib-opt/GHCup/OptParse/Upgrade.hs +155/−0
• lib-opt/GHCup/OptParse/Whereis.hs +343/−0
• lib/GHCup.hs +16/−7
• lib/GHCup/Download.hs +71/−19
• lib/GHCup/Errors.hs +63/−8
• lib/GHCup/GHC.hs +140/−91
• lib/GHCup/HLS.hs +7/−4
• lib/GHCup/List.hs +1/−12
• lib/GHCup/Platform.hs +161/−0
• lib/GHCup/Prelude.hs +26/−0
• lib/GHCup/Prelude/MegaParsec.hs +20/−8
• lib/GHCup/Prelude/Process.hs +1/−0
• lib/GHCup/Prelude/Process/Posix.hs +11/−1
• lib/GHCup/Prelude/Process/Windows.hs +10/−2
• lib/GHCup/Prelude/Version/QQ.hs +1/−23
• lib/GHCup/Stack.hs +1/−1
• lib/GHCup/Types.hs +111/−43
• lib/GHCup/Types/JSON.hs +128/−75
• lib/GHCup/Types/JSON/Versions.hs +90/−0
• lib/GHCup/Types/Stack.hs +180/−0
• lib/GHCup/Utils.hs +25/−49
• lib/GHCup/Version.hs +15/−41
• test/GHCup/ArbitraryTypes.hs +0/−204
• test/GHCup/Prelude/File/Posix/TraversalsSpec.hs +0/−40
• test/GHCup/Types/JSONSpec.hs +0/−22
• test/GHCup/Utils/FileSpec.hs +0/−58
• test/Main.hs +0/−9
• test/Spec.hs +0/−2
• test/data/dir/.keep +0/−0
• test/data/file +0/−0
• test/ghcup-test/GHCup/ArbitraryTypes.hs +204/−0
• test/ghcup-test/GHCup/Prelude/File/Posix/TraversalsSpec.hs +40/−0
• test/ghcup-test/GHCup/Types/JSONSpec.hs +22/−0
• test/ghcup-test/GHCup/Utils/FileSpec.hs +58/−0
• test/ghcup-test/Main.hs +9/−0
• test/ghcup-test/Spec.hs +2/−0
• test/ghcup-test/data/dir/.keep +0/−0
• test/ghcup-test/data/file +0/−0
• test/ghcup-test/golden/unix/GHCupInfo.json +18950/−0
• test/ghcup-test/golden/windows/GHCupInfo.json +19961/−0
• test/golden/unix/GHCupInfo.json +0/−18950
• test/golden/windows/GHCupInfo.json +0/−20020
• test/optparse-test/ChangeLogTest.hs +51/−0
• test/optparse-test/CompileTest.hs +191/−0
• test/optparse-test/ConfigTest.hs +41/−0
• test/optparse-test/GCTest.hs +42/−0
• test/optparse-test/InstallTest.hs +203/−0
• test/optparse-test/ListTest.hs +46/−0
• test/optparse-test/Main.hs +33/−0
• test/optparse-test/OtherCommandTest.hs +38/−0
• test/optparse-test/RmTest.hs +62/−0
• test/optparse-test/RunTest.hs +68/−0
• test/optparse-test/SetTest.hs +156/−0
• test/optparse-test/UnsetTest.hs +50/−0
• test/optparse-test/UpgradeTest.hs +38/−0
• test/optparse-test/Utils.hs +34/−0
• test/optparse-test/WhereisTest.hs +42/−0

@@ -1,8 +1,20 @@ # Revision history for ghcup -## 0.1.19.5 -- ????-?-??+## 0.1.20.0 -- 2023-11-10 -* support JS cross compilers wrt [#838](https://github.com/haskell/ghcup-hs/issues/838)+### New features++* support TUI on windows thanks to the work from vty and brick maintainers (Chris Hackett, Timofey Zakrevskiy, Jonathan Daugherty, ...), wrt [#912](https://github.com/haskell/ghcup-hs/pull/912)+* support JS and wasm cross compilers wrt [#838](https://github.com/haskell/ghcup-hs/issues/838), thanks to Sylvain Henry and IOG+* Support stacks installation strategy and metadata wrt [#892](https://github.com/haskell/ghcup-hs/issues/892)+  - you can now enable stacks installation method via `ghcup config set url-source '["GHCupURL", "StackSetupURL"]'`... for more information, check the [documentation](https://www.haskell.org/ghcup/guide/#using-stacks-setup-info-metadata-to-install-ghc)++### Improvements and bug fixes++* fix segfault in TUI when hitting enter early wrt [#887](https://github.com/haskell/ghcup-hs/issues/887)+* Improve key handling in TUI, fixes [#875](https://github.com/haskell/ghcup-hs/issues/875)+* add explicit support for Void Linux and Rocky Linux (this requires a metadata version bump to `ghcup-0.0.8.yaml`)+* optparse cli interface now has a test suite thanks to Lei Zhu, wrt [#862](https://github.com/haskell/ghcup-hs/pull/862)  ## 0.1.19.4 -- 2023-7-02 

@@ -5,18 +5,19 @@ {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE RankNTypes        #-} {-# LANGUAGE ViewPatterns      #-}+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}  module BrickMain where  import           GHCup import           GHCup.Download import           GHCup.Errors-import           GHCup.Types.Optics ( getDirs )+import           GHCup.Types.Optics ( getDirs, getPlatformReq ) import           GHCup.Types         hiding ( LeanAppState(..) ) import           GHCup.Utils import           GHCup.OptParse.Common (logGHCPostRm) import           GHCup.Prelude ( decUTF8Safe )-import           GHCup.Prelude.File import           GHCup.Prelude.Logger import           GHCup.Prelude.Process import           GHCup.Prompts@@ -30,6 +31,7 @@                                                 , listAttr                                                 ) import           Codec.Archive+import           Control.Applicative import           Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) import           Control.Monad.Fail             ( MonadFail )@@ -45,10 +47,9 @@ import           Data.Vector                    ( Vector                                                 , (!?)                                                 )-import           Data.Versions           hiding ( str )+import           Data.Versions import           Haskus.Utils.Variant.Excepts import           Prelude                 hiding ( appendFile )-import           System.FilePath import           System.Exit import           System.IO.Unsafe import           Text.PrettyPrint.HughesPJClass ( prettyShow )@@ -60,9 +61,34 @@ import qualified Graphics.Vty                  as Vty import qualified Data.Vector                   as V import System.Environment (getExecutablePath)+#if !IS_WINDOWS+import           GHCup.Prelude.File+import           System.FilePath import qualified System.Posix.Process          as SPP+#endif  +installedSign :: String+#if IS_WINDOWS+installedSign = "I "+#else+installedSign = "✓ "+#endif++setSign :: String+#if IS_WINDOWS+setSign = "IS"+#else+setSign = "✔✔"+#endif++notInstalledSign :: String+#if IS_WINDOWS+notInstalledSign = "X "+#else+notInstalledSign = "✗ "+#endif+ hiddenTools :: [Tool] hiddenTools = [] @@ -94,7 +120,7 @@   keyHandlers :: KeyBindings-            -> [ ( Vty.Key+            -> [ ( KeyCombination                  , BrickSettings -> String                  , BrickState -> EventM String BrickState ()                  )@@ -131,7 +157,10 @@ showKey Vty.KDown = "↓" showKey key = tail (show key) +showMod :: Vty.Modifier -> String+showMod = tail . show + ui :: AttrMap -> BrickState -> Widget String ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}   = padBottom Max@@ -147,7 +176,7 @@       . txtWrap       . T.pack       . foldr1 (\x y -> x <> "  " <> y)-      . fmap (\(key, s, _) -> showKey key <> ":" <> s as)+      . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)       $ keyHandlers appKeys   header =     minHSize 2 emptyWidget@@ -161,9 +190,9 @@     in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis   renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =     let marks = if-          | lSet       -> (withAttr (attrName "set") $ str "✔✔")-          | lInstalled -> (withAttr (attrName "installed") $ str "✓ ")-          | otherwise  -> (withAttr (attrName "not-installed") $ str "✗ ")+          | lSet       -> (withAttr (attrName "set") $ str setSign)+          | lInstalled -> (withAttr (attrName "installed") $ str installedSign)+          | otherwise  -> (withAttr (attrName "not-installed") $ str notInstalledSign)         ver = case lCross of           Nothing -> T.unpack . prettyVer $ lVer           Just c  -> T.unpack (c <> "-" <> prettyVer lVer)@@ -218,7 +247,6 @@   printNotes ListResult {..} =     (if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty       )-      ++ (if fromSrc then [withAttr (attrName "compiled") $ str "compiled"] else mempty)       ++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)       ++ (case lReleaseDay of             Nothing -> mempty@@ -322,12 +350,12 @@     (MouseDown _ Vty.BScrollDown _ _) ->       put (BrickState { appState = moveCursor 1 appState Down, .. })     (VtyEvent (Vty.EvResize _ _)) -> put st-    (VtyEvent (Vty.EvKey Vty.KUp _)) ->+    (VtyEvent (Vty.EvKey Vty.KUp [])) ->       put BrickState{ appState = moveCursor 1 appState Up, .. }-    (VtyEvent (Vty.EvKey Vty.KDown _)) ->+    (VtyEvent (Vty.EvKey Vty.KDown [])) ->       put BrickState{ appState = moveCursor 1 appState Down, .. }-    (VtyEvent (Vty.EvKey key _)) ->-      case find (\(key', _, _) -> key' == key) (keyHandlers kb) of+    (VtyEvent (Vty.EvKey key mods)) ->+      case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of         Nothing -> put st         Just (_, _, handler) -> handler st     _ -> put st@@ -433,7 +461,7 @@                                   (lTool e `notElem` hiddenTools)  -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)+install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)          => BrickState          -> (Int, ListResult)          -> m (Either String ())@@ -464,6 +492,11 @@               , ToolShadowed               , UninstallFailed               , MergeFileTreeError+              , NoCompatiblePlatform+              , GHCup.Errors.ParseError+              , UnsupportedSetupCombo+              , DistroNotFound+              , NoCompatibleArch               ]    run (do@@ -492,12 +525,15 @@             forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg             case lTool of               GHCup -> do+#if !IS_WINDOWS                 up <- liftIO $ fmap (either (const Nothing) Just)                   $ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)                 when ((normalise <$> up) == Just (normalise ce)) $                   -- TODO: track cli arguments of previous invocation                   liftIO $ SPP.executeFile ce False ["tui"] Nothing+#else                 logInfo "Please restart 'ghcup' for the changes to take effect"+#endif               _ -> pure ()             pure $ Right ()           VRight (vi, _, _) -> do@@ -510,7 +546,7 @@             <> "Also check the logs in ~/.ghcup/logs"  -set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)+set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)      => BrickState      -> (Int, ListResult)      -> m (Either String ())@@ -652,8 +688,10 @@    r <-     flip runReaderT settings-    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]-    $ liftE getDownloadsF+    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]+    $ do+      pfreq <- lift getPlatformReq+      liftE $ getDownloadsF pfreq    case r of     VRight a -> pure $ Right a

@@ -1,363 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}---module GHCup.OptParse (-    module GHCup.OptParse.Common-  , module GHCup.OptParse.Install-  , module GHCup.OptParse.Test-  , 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-#ifndef DISABLE_UPGRADE-  , module GHCup.OptParse.Upgrade-#endif-  , 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.Run-  , module GHCup.OptParse-) where---import           GHCup.OptParse.Common-import           GHCup.OptParse.Install-import           GHCup.OptParse.Test-import           GHCup.OptParse.Set-import           GHCup.OptParse.UnSet-import           GHCup.OptParse.Rm-import           GHCup.OptParse.Run-import           GHCup.OptParse.Compile-import           GHCup.OptParse.Config-import           GHCup.OptParse.Whereis-import           GHCup.OptParse.List-#ifndef DISABLE_UPGRADE-import           GHCup.OptParse.Upgrade-#endif-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-  , optMetaCache   :: Maybe Integer-  , optMetaMode    :: Maybe MetaMode-  , optPlatform    :: Maybe PlatformRequest-  , 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)-  | Test TestCommand-  | InstallCabalLegacy InstallOptions-  | Set (Either SetCommand SetOptions)-  | UnSet UnsetCommand-  | List ListOptions-  | Rm (Either RmCommand RmOptions)-  | DInfo-  | Compile CompileCommand-  | Config ConfigCommand-  | Whereis WhereisOptions WhereisCommand-#ifndef DISABLE_UPGRADE-  | Upgrade UpgradeOpts Bool Bool-#endif-  | ToolRequirements ToolReqOpts-  | ChangeLog ChangeLogOptions-  | Nuke-#if defined(BRICK)-  | Interactive-#endif-  | Prefetch PrefetchCommand-  | GC GCOptions-  | Run RunOptions-  | PrintAppErrors----opts :: Parser Options-opts =-  Options-    <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")-    <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")-    <*> optional (option auto (long "metadata-caching" <> metavar "SEC" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable"))-    <*> optional (option auto (long "metadata-fetching-mode" <> metavar "<Strict|Lax>" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))"))-    <*> 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 parseUri)-            (  short 's'-            <> long "url-source"-            <> metavar "URL"-            <> help "Alternative ghcup download info url"-            <> internal-            <> completer fileUri-            )-          )-    <*> (fmap . fmap) not (invertableSwitch "verify" (Just '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-          <> completer (listCompleter ["always", "errors", "never"])-          ))-    <*> optional (option-          (eitherReader downloaderParser)-          (  long "downloader"-#if defined(INTERNAL_DOWNLOADER)-          <> metavar "<internal|curl|wget>"-          <> help-          "Downloader to use (default: internal)"-          <> completer (listCompleter ["internal", "curl", "wget"])-#else-          <> metavar "<curl|wget>"-          <> help-          "Downloader to use (default: curl)"-          <> completer (listCompleter ["curl", "wget"])-#endif-          <> hidden-          ))-    <*> invertableSwitch "offline" (Just '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)"-          <> completer (listCompleter ["strict", "lax", "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-           "test"-           (info-             (Test <$> testParser <**> helper)-             (  progDesc "Run tests for a tool (if any) [EXPERIMENTAL!]"-             <> footerDoc (Just $ text testFooter)-             )-           )-      <> 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"-                 <> footerDoc (Just $ text listToolFooter))-           )-      <> command-           "upgrade"-           (info-             (    (Upgrade <$> upgradeOptsP <*> switch-                    (short 'f' <> long "force" <> help "Force update")-                    <*> switch-                    (long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")-                  )-             <**> 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 ))-           )-      <> command-              "run"-               (Run-               <$>-                 info-                   (runOpts <**> helper)-                   (progDesc "Run a command with the given tool in PATH"-                   <> footerDoc ( Just $ text runFooter )-                   )-               )-      <> commandGroup "Main commands:"-      )-    <|> subparser-          (  command-              "debug-info"-              ((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))-          <> command-               "tool-requirements"-               (   ToolRequirements-               <$> info (toolReqP <**> 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-          )-     <|> subparser-          (command-              "print-app-errors"-               (info (pure PrintAppErrors <**> helper)-                     (progDesc ""))-           <> internal-          )

@@ -1,148 +0,0 @@-{-# 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.Errors-import           GHCup.OptParse.Common-import           GHCup.Prelude-import           GHCup.Prelude.Logger-import           GHCup.Prelude.String.QQ-import           GHCup.Prelude.Process (exec)--#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 URI.ByteString (serializeURIRef')-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-                "hls"   -> Right HLS-                e       -> Left e-              )-            )-            (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help-              "Open changelog for given tool (default: ghc)"-              <> completer toolCompleter-            )-          )-    <*> optional (toolVersionTagArgument [] 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' = fromMaybe-        (ToolTag Latest)-        clToolVer-      muri = getChangeLog dls tool ver'-  case muri of-    Nothing -> do-      runLogger-        (logWarn $-          "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> T.pack (prettyShow 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 $ prettyHFError e)-                      >> pure (ExitFailure 13)-        else liftIO $ putStrLn uri' >> pure ExitSuccess

@@ -1,830 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE ViewPatterns      #-}--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.Prelude-import           GHCup.Prelude.Process-import           GHCup.Prelude.Logger-import           GHCup.Prelude.MegaParsec--import           Control.DeepSeq-import           Control.Concurrent-import           Control.Concurrent.Async-import           Control.Exception.Safe-import           Control.Monad.Identity (Identity(..))-#if !MIN_VERSION_base(4,13,0)-import           Control.Monad.Fail             ( MonadFail )-#endif-import           Control.Monad.Reader-import           Data.Aeson-#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key    as KM-import qualified Data.Aeson.KeyMap as KM-#else-import qualified Data.HashMap.Strict as KM-#endif-import           Data.ByteString.Lazy           ( ByteString )-import           Data.Bifunctor-import           Data.Char-import           Data.Either-import           Data.Functor-import           Data.List                      ( nub, sort, sortBy, isPrefixOf, stripPrefix )-import           Data.Maybe-import           Data.Text                      ( Text )-import           Data.Time.Calendar             ( Day )-import           Data.Time.Format               ( parseTimeM, defaultTimeLocale )-import           Data.Versions           hiding ( str )-import           Data.Void-import qualified Data.Vector      as V-import           GHC.IO.Exception-import           Haskus.Utils.Variant.Excepts-import           Options.Applicative     hiding ( style )-import           Prelude                 hiding ( appendFile )-import           Safe-import           System.Process                  ( readProcess )-import           System.FilePath-import           Text.HTML.TagSoup       hiding ( Tag )-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 qualified System.FilePath.Posix         as FP-import GHCup.Version-import Control.Exception (evaluate)-import qualified Cabal.Config            as CC---    --------------    --[ Types ]---    ------------------ a superset of ToolVersion-data SetToolVersion = SetGHCVersion GHCTargetVersion-                    | SetToolVersion Version-                    | SetToolTag Tag-                    | SetToolDay Day-                    | SetRecommended-                    | SetNext--prettyToolVer :: ToolVersion -> String-prettyToolVer (GHCVersion v')  = T.unpack $ tVerToText v'-prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'-prettyToolVer (ToolTag t)      = show t-prettyToolVer (ToolDay day)    = show day--toSetToolVer :: Maybe ToolVersion -> SetToolVersion-toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'-toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'-toSetToolVer (Just (ToolTag t')) = SetToolTag t'-toSetToolVer (Just (ToolDay d')) = SetToolDay d'-toSetToolVer Nothing = SetRecommended-----    ---------------    --[ Parser ]---    -----------------toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion-toolVersionTagArgument criteria tool =-  argument (eitherReader (parser tool))-    (metavar (mv tool)-    <> completer (tagCompleter (fromMaybe GHC tool) [])-    <> foldMap (completer . versionCompleter criteria) tool)- where-  mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE"-  mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE"-  mv _          = "VERSION|TAG|RELEASE_DATE"--  parser (Just GHC) = ghcVersionTagEither-  parser Nothing    = ghcVersionTagEither-  parser _          = toolVersionTagEither---versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version-versionParser' criteria tool = argument-  (eitherReader (first show . version . T.pack))-  (metavar "VERSION"  <> foldMap (completer . versionCompleter criteria) tool)--ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion-ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)-                                            (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-    -> Maybe 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")-    -> Maybe 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 maybe mempty short shortopt)-    <|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty 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-    ]---uriParser :: String -> Either String URI-uriParser = 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 && isAbsolute f of-              True -> Right $ normalise f-              False -> Left "Please enter a valid filepath for isolate dir."---- this accepts cross prefix-ghcVersionTagEither :: String -> Either String ToolVersion-ghcVersionTagEither s' =-  second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')---- this ignores cross prefix-toolVersionTagEither :: String -> Either String ToolVersion-toolVersionTagEither s' =-  second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')--tagEither :: String -> Either String Tag-tagEither s' = case fmap toLower s' of-  "recommended"              -> Right Recommended-  "latest"                   -> Right Latest-  "latest-prerelease"        -> Right LatestPrerelease-  "latest-nightly"           -> Right LatestNightly-  ('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---ghcVersionEither :: String -> Either String GHCTargetVersion-ghcVersionEither =-  first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack--toolVersionEither :: String -> Either String Version-toolVersionEither =-  first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . 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')--dayParser :: String -> Either String Day-dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right-            $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s---criteriaParser :: String -> Either String ListCriteria-criteriaParser s' | t == T.pack "installed"   = Right $ ListInstalled True-                  | t == T.pack "set"         = Right $ ListSet True-                  | t == T.pack "available"   = Right $ ListAvailable True-                  | t == T.pack "+installed"  = Right $ ListInstalled True-                  | t == T.pack "+set"        = Right $ ListSet True-                  | t == T.pack "+available"  = Right $ ListAvailable True-                  | t == T.pack "-installed"  = Right $ ListInstalled False-                  | t == T.pack "-set"        = Right $ ListSet False-                  | t == T.pack "-available"  = Right $ ListAvailable False-                  | 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')--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 ]---    ---------------------toolCompleter :: Completer-toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]--gitFileUri :: [String] -> Completer-gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)--fileUri :: Completer-fileUri = mkCompleter $ fileUri' []--fileUri' :: [String] -> String -> IO [String]-fileUri' add = \case-  "" -> do-    pwd <- getCurrentDirectory-    pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add-  xs-   | "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>-      case stripPrefix "file://" xs of-        Nothing -> pure []-        Just r ->  do-          pwd <- getCurrentDirectory-          dirs  <- compgen "directory" r ["-S", "/"]-          files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []-          pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])-   | xs `isPrefixOf` "file:///" -> pure ["file:///"]-   | xs `isPrefixOf` "https://" -> pure ["https://"]-   | xs `isPrefixOf` "http://"  -> pure ["http://"]-   | otherwise -> pure []- where-  compgen :: String -> String -> [String] -> IO [String]-  compgen action' r opts = do-    let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]-    result <- tryIO $ readProcess "bash" ["-c", cmd] ""-    return . lines . either (const []) id $ result--  -- | Strongly quote the string we pass to compgen.-  ---  -- We need to do this so bash doesn't expand out any ~ or other-  -- chars we want to complete on, or emit an end of line error-  -- when seeking the close to the quote.-  -- -  -- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote-  requote :: String -> String-  requote s =-    let-      -- Bash doesn't appear to allow "mixed" escaping-      -- in bash completions. So we don't have to really-      -- worry about people swapping between strong and-      -- weak quotes.-      unescaped =-        case s of-          -- It's already strongly quoted, so we-          -- can use it mostly as is, but we must-          -- ensure it's closed off at the end and-          -- there's no single quotes in the-          -- middle which might confuse bash.-          ('\'': rs) -> unescapeN rs--          -- We're weakly quoted.-          ('"': rs)  -> unescapeD rs--          -- We're not quoted at all.-          -- We need to unescape some characters like-          -- spaces and quotation marks.-          elsewise   -> unescapeU elsewise-    in-      strong unescaped--    where-      strong ss = '\'' : foldr go "'" ss-        where-          -- If there's a single quote inside the-          -- command: exit from the strong quote and-          -- emit it the quote escaped, then resume.-          go '\'' t = "'\\''" ++ t-          go h t    = h : t--      -- Unescape a strongly quoted string-      -- We have two recursive functions, as we-      -- can enter and exit the strong escaping.-      unescapeN = goX-        where-          goX ('\'' : xs) = goN xs-          goX (x : xs) = x : goX xs-          goX [] = []--          goN ('\\' : '\'' : xs) = '\'' : goN xs-          goN ('\'' : xs) = goX xs-          goN (x : xs) = x : goN xs-          goN [] = []--      -- Unescape an unquoted string-      unescapeU = goX-        where-          goX [] = []-          goX ('\\' : x : xs) = x : goX xs-          goX (x : xs) = x : goX xs--      -- Unescape a weakly quoted string-      unescapeD = goX-        where-          -- Reached an escape character-          goX ('\\' : x : xs)-            -- If it's true escapable, strip the-            -- slashes, as we're going to strong-            -- escape instead.-            | x `elem` ("$`\"\\\n" :: String) = x : goX xs-            | otherwise = '\\' : x : goX xs-          -- We've ended quoted section, so we-          -- don't recurse on goX, it's done.-          goX ('"' : xs)-            = xs-          -- Not done, but not a special character-          -- just continue the fold.-          goX (x : xs)-            = x : goX xs-          goX []-            = []---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-        (defaultSettings { noNetwork = True })-        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", "latest-prerelease"] ++ add)--versionCompleter :: [ListCriteria] -> Tool -> Completer-versionCompleter criteria tool = versionCompleter' criteria tool (const True)--versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer-versionCompleter' criteria tool filter' = listIOCompleter $ do-  dirs' <- liftIO getAllDirs-  let loggerConfig = LoggerConfig-        { lcPrintDebug   = False-        , consoleOutter  = mempty-        , fileOutter     = mempty-        , fancyColors    = False-        }-  let settings = defaultSettings { noNetwork = True }-  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 False False (Nothing, Nothing)-      return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions---toolDlCompleter :: Tool -> Completer-toolDlCompleter tool = mkCompleter $ \case-  "" -> pure (initUrl tool <> ["https://", "http://", "file:///"])-  word-    | "file://" `isPrefixOf` word -> fileUri' [] word-    -- downloads.haskell.org-    | "https://downloads.haskell.org/" `isPrefixOf` word ->-        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word--    -- github releases-    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word-    , let xs = splitPath word-    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->-        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"-    | "https://github.com/commercialhaskell/stack/releases/download/" == word-    , let xs = splitPath word-    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->-        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"--    -- github release assets-    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word-    , let xs = splitPath word-    , (length xs == 7 && last word == '/') || length xs == 8-    , let rel = xs !! 6-    , length rel > 1 -> do-        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)-    | "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word-    , let xs = splitPath word-    , (length xs == 7 && last word == '/') || length xs == 8-    , let rel = xs !! 6-    , length rel > 1 -> do-        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)--    -- github-    | "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]-    | "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]-    | "https://g" `isPrefixOf` word-    , tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]-    | "https://g" `isPrefixOf` word-    , tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]--    | "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool--    | "h" `isPrefixOf` word -> pure $ initUrl tool--    | word `isPrefixOf` "file:///" -> pure ["file:///"]-    | word `isPrefixOf` "https://" -> pure ["https://"]-    | word `isPrefixOf` "http://"  -> pure ["http://"]--    | otherwise -> pure []- where-  initUrl :: Tool -> [String]-  initUrl GHC   = [ "https://downloads.haskell.org/~ghc/"-                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"-                  ]-  initUrl Cabal = [ "https://downloads.haskell.org/~cabal/"-                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"-                  ]-  initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ]-  initUrl HLS   = [ "https://github.com/haskell/haskell-language-server/releases/download/"-                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"-                  ]-  initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/"-                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"-                  ]--  completePrefix :: String -- ^ url, e.g.    'https://github.com/haskell/haskell-languag'-                 -> String -- ^ match, e.g.  'haskell-language-server'-                 -> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'-  completePrefix url match =-    let base = FP.takeDirectory url-        fn   = FP.takeFileName url-    in if fn `isPrefixOf` match then base <> "/" <> match else url--  prefixMatch :: String -> [String] -> [String]-  prefixMatch pref = filter (pref `isPrefixOf`)--  fromHRef :: String -> IO [String]-  fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->-      pure-        . fmap (T.unpack . decUTF8Safe' . fromAttrib "href")-        . filter isTagOpen-        . filter (~== ("<a href>" :: String))-        . parseTags-        $ stdout--  withCurl :: String                      -- ^ url-           -> Int                         -- ^ delay-           -> (ByteString -> IO [String]) -- ^ callback-           -> IO [String]-  withCurl url delay cb = do-    let limit = threadDelay delay-    race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case-      Right (CapturedProcess {_exitCode, _stdOut}) -> do-        case _exitCode of-          ExitSuccess ->-            (try @_ @SomeException . cb $ _stdOut) >>= \case-              Left _ ->  pure []-              Right r' -> do-                r <- try @_ @SomeException-                  . evaluate-                  . force-                  $ r'-                either (\_ -> pure []) pure r-          ExitFailure _ -> pure []-      Left _ -> pure []--  getGithubReleases :: String-                    -> String-                    -> IO [String]-  getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do-    Just xs <- pure $ decode' @Array stdout-    fmap V.toList $ forM xs $ \x -> do-      (Object r) <- pure x-      Just (String name) <- pure $ KM.lookup (mkval "tag_name") r-      pure $ T.unpack name-   where-    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"--  getGithubAssets :: String-                  -> String-                  -> String-                  -> IO [String]-  getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do-    Just xs <- pure $ decode' @Object stdout-    Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs-    as <- fmap V.toList $ forM assets $ \val -> do-      (Object asset) <- pure val-      Just (String name) <- pure $ KM.lookup (mkval "name") asset-      pure $ T.unpack name-    pure as-   where-    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag---#if MIN_VERSION_aeson(2,0,0)-  mkval = KM.fromString-#else-  mkval = id-#endif-------    ------------------    --[ Utilities ]---    --------------------fromVersion :: ( HasLog env-               , MonadFail m-               , MonadReader env m-               , HasGHCupInfo env-               , HasDirs env-               , MonadThrow m-               , MonadIO m-               , MonadCatch m-               )-            => Maybe ToolVersion-            -> Tool-            -> Excepts-                 '[ TagNotFound-                  , DayNotFound-                  , 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-                   , DayNotFound-                   , NextVerNotFound-                   , NoToolVersionSet-                   ] m (GHCTargetVersion, Maybe VersionInfo)-fromVersion' SetRecommended tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  second Just <$> getRecommended dls tool-    ?? TagNotFound Recommended tool-fromVersion' (SetGHCVersion v) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  let vi = getVersionInfo v tool dls-  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here-    Left _ -> pure (v, vi)-    Right pvpIn ->-      lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case-        Just (pvp_, vi', mt) -> do-          v' <- lift $ pvpToVersion pvp_ ""-          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')-          pure (GHCTargetVersion mt v', Just vi')-        Nothing -> pure (v, vi)-fromVersion' (SetToolVersion (mkTVer -> v)) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  let vi = getVersionInfo v tool dls-  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here-    Left _ -> pure (v, vi)-    Right pvpIn ->-      lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case-        Just (pvp_, vi', mt) -> do-          v' <- lift $ pvpToVersion pvp_ ""-          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')-          pure (GHCTargetVersion mt v', Just vi')-        Nothing -> pure (v, vi)-fromVersion' (SetToolTag Latest) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool-fromVersion' (SetToolDay day) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id Just <$> case getByReleaseDay dls tool day of-                          Left ad -> throwE $ DayNotFound day tool ad-                          Right v -> pure v-fromVersion' (SetToolTag LatestPrerelease) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool-fromVersion' (SetToolTag LatestNightly) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool-fromVersion' (SetToolTag Recommended) tool = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool-fromVersion' (SetToolTag (Base pvp'')) GHC = do-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-  bimap id 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 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 [(Tool, GHCTargetVersion)]-checkForUpdates = do-  GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo-  lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)-  let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled--  ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do-    (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer-    if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing--  otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->-    forMM (getLatest dls t) $ \(l, _) -> do-      let mver = latestInstalled t-      forMM mver $ \ver ->-        if (l > ver) then pure $ Just (t, l) else pure Nothing--  pure $ catMaybes (ghcup:otherTools)- where-  forMM a f = fmap join $ forM a f---logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m ()-logGHCPostRm ghcVer = do-  cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store")-    (runIdentity . CC.cfgStoreDir <$> CC.readConfig)-  let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))-  logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir-

@@ -1,614 +0,0 @@-{-# 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 qualified GHCup.GHC as GHC-import qualified GHCup.HLS as HLS-import           GHCup.Errors-import           GHCup.Types-import           GHCup.Types.Optics-import           GHCup.Utils-import           GHCup.Prelude.Logger-import           GHCup.Prelude.String.QQ-import           GHCup.OptParse.Common--#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, pvp )-import qualified Data.Versions as V-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           URI.ByteString          hiding ( uriParser )-import qualified Data.Text                     as T-import Control.Exception.Safe (MonadMask, displayException)-import System.FilePath (isPathSeparator)-import Text.Read (readEither)-----    -----------------    --[ Commands ]---    -------------------data CompileCommand = CompileGHC GHCCompileOptions-                    | CompileHLS HLSCompileOptions----    ----------------    --[ Options ]---    ------------------data GHCCompileOptions = GHCCompileOptions-  { targetGhc    :: GHC.GHCVer-  , bootstrapGhc :: Either Version FilePath-  , jobs         :: Maybe Int-  , buildConfig  :: Maybe FilePath-  , patches      :: Maybe (Either FilePath [URI])-  , crossTarget  :: Maybe Text-  , addConfArgs  :: [Text]-  , setCompile   :: Bool-  , ovewrwiteVer :: Maybe Version-  , buildFlavour :: Maybe String-  , hadrian      :: Bool-  , isolateDir   :: Maybe FilePath-  }---data HLSCompileOptions = HLSCompileOptions-  { targetHLS    :: HLS.HLSVer-  , jobs         :: Maybe Int-  , setCompile   :: Bool-  , updateCabal  :: Bool-  , ovewrwiteVer :: Either Bool Version-  , isolateDir   :: Maybe FilePath-  , cabalProject :: Maybe (Either FilePath URI)-  , cabalProjectLocal :: Maybe URI-  , patches      :: Maybe (Either FilePath [URI])-  , targetGHCs   :: [ToolVersion]-  , cabalArgs    :: [Text]-  }-----    ----------------    --[ 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 --ghc arguments are necessary to specify which GHC version to build for/against.-  These need to be available in PATH prior to compilation.--Examples:-  # compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build-  ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update-  # compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state-  ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')-  # compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name-  ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]---ghcCompileOpts :: Parser GHCCompileOptions-ghcCompileOpts =-  GHCCompileOptions-    <$> ((GHC.SourceDist <$> option-          (eitherReader-            (first (const "Not a valid version") . version . T.pack)-          )-          (short 'v' <> long "version" <> metavar "VERSION" <> help-            "The tool version to compile"-            <> (completer $ versionCompleter [] GHC)-          )-          ) <|>-          (GHC.GitDist <$> (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)"-            <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])-            ))-          ))-          <|>-          (-           GHC.RemoteDist <$> (option-            (eitherReader uriParser)-            (long "remote-source-dist" <> metavar "URI" <> help-              "URI (https/http/file) to a GHC source distribution"-              <> completer fileUri-            )-          )-          )-          )-    <*> 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)"-          <> (completer $ versionCompleter [] GHC)-          )-    <*> optional-          (option-            (eitherReader (readEither @Int))-            (short 'j' <> long "jobs" <> metavar "JOBS" <> help-              "How many jobs to use for make"-              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))-            )-          )-    <*> optional-          (option-            str-            (short 'c' <> long "config" <> metavar "CONFIG" <> help-              "Absolute path to build config file"-             <> completer (bashCompleter "file")-            )-          )-    <*> (optional-          (-            (fmap Right $ many $ option-              (eitherReader uriParser)-              (long "patch" <> metavar "PATCH_URI" <> help-                "URI to a patch (https/http/file)"-               <> completer fileUri-              )-            )-            <|>-            (fmap Left $ 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. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)"-               <> completer (bashCompleter "directory")-              )-            )-          )-        )-    <*> 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 compile configure, prefix with '-- ' (longopts)"))-    <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (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'"-            <> (completer $ versionCompleter [] GHC)-            )-          )-    <*> 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"-            <> completer (bashCompleter "directory")-            )-           )--hlsCompileOpts :: Parser HLSCompileOptions-hlsCompileOpts =-  HLSCompileOptions-    <$> ((HLS.HackageDist <$> option-          (eitherReader-            ((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack)-          )-          (short 'v' <> long "version" <> metavar "VERSION" <> help-            "The version to compile (pulled from hackage)"-            <> (completer $ versionCompleter' [] HLS (either (const False) (const True) . V.pvp . V.prettyVer))-          )-          )-          <|>-          (HLS.GitDist <$> (GitBranch <$> option-          str-          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help-            "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"-          ) <*>-          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"-            <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])-          ))-          ))-          <|>-          (HLS.SourceDist <$> (option-            (eitherReader-              (first (const "Not a valid version") . version . T.pack)-            )-          (long "source-dist" <> metavar "VERSION" <> help-            "The version to compile (pulled from packaged git sources)"-            <> (completer $ versionCompleter [] HLS)-          )-          ))-          <|>-          (-           HLS.RemoteDist <$> (option-            (eitherReader uriParser)-            (long "remote-source-dist" <> metavar "URI" <> help-              "URI (https/http/file) to a HLS source distribution"-              <> completer fileUri-            )-          )-          )-          )-    <*> optional-          (option-            (eitherReader (readEither @Int))-            (short 'j' <> long "jobs" <> metavar "JOBS" <> help-              "How many jobs to use for make"-              <> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))-            )-          )-    <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))-    <*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")-    <*>-         (-          (Right <$> 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'"-            <> (completer $ versionCompleter [] HLS)-            )-          )-          <|>-          (Left <$> (switch-                      (long "git-describe-version"-                         <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."-                      )-                    )-          )-          )-    <*> 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"-            <> completer (bashCompleter "directory")-            )-           )-    <*> optional-          (option-            ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))-            (long "cabal-project" <> metavar "CABAL_PROJECT" <> help-              "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."-              <> completer fileUri-            )-          )-    <*> optional-          (option-            (eitherReader uriParser)-            (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help-              "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."-              <> completer fileUri-            )-          )-    <*> (optional-          (-            (fmap Right $ many $ option-              (eitherReader uriParser)-              (long "patch" <> metavar "PATCH_URI" <> help-                "URI to a patch (https/http/file)"-              <> completer fileUri-              )-            )-            <|>-            (fmap Left $ 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)"-              <> completer (bashCompleter "directory")-              )-            )-          )-        )-    <*> some (-          option (eitherReader ghcVersionTagEither)-            (  long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)"-            <> completer (tagCompleter GHC [])-            <> completer (versionCompleter [] GHC))-        )-    <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))------    ----------------------------    --[ Effect interpreters ]---    ------------------------------type GHCEffects = '[ AlreadyInstalled-                  , BuildFailed-                  , DigestError-                  , ContentLengthError-                  , GPGError-                  , DownloadFailed-                  , GHCupSetError-                  , NoDownload-                  , NotFoundInPATH-                  , PatchFailed-                  , UnknownArchive-                  , TarDirDoesNotExist-                  , NotInstalled-                  , DirNotEmpty-                  , ArchiveResult-                  , FileDoesNotExistError-                  , HadrianNotFound-                  , InvalidBuildConfig-                  , ProcessError-                  , CopyError-                  , BuildFailed-                  , UninstallFailed-                  , MergeFileTreeError-                  ]-type HLSEffects = '[ AlreadyInstalled-                  , BuildFailed-                  , DigestError-                  , ContentLengthError-                  , GPGError-                  , DownloadFailed-                  , GHCupSetError-                  , NoDownload-                  , NotFoundInPATH-                  , PatchFailed-                  , UnknownArchive-                  , TarDirDoesNotExist-                  , TagNotFound-                  , DayNotFound-                  , NextVerNotFound-                  , NoToolVersionSet-                  , NotInstalled-                  , DirNotEmpty-                  , ArchiveResult-                  , UninstallFailed-                  , MergeFileTreeError-                  ]----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-      -> Dirs-      -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a))-      -> (ReaderT LeanAppState m () -> m ())-      -> m ExitCode-compile compileCommand settings Dirs{..} runAppState runLogger = do-  case compileCommand of-    (CompileHLS HLSCompileOptions { .. }) -> do-      runCompileHLS runAppState (do-        case targetHLS of-          HLS.SourceDist targetVer -> do-            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-            let vi = getVersionInfo (mkTVer 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-          _ -> pure ()-        ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)-        targetVer <- liftE $ compileHLS-                    targetHLS-                    ghcs-                    jobs-                    ovewrwiteVer-                    (maybe GHCupInternal IsolateDir isolateDir)-                    cabalProject-                    cabalProjectLocal-                    updateCabal-                    patches-                    cabalArgs-        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-        let vi = getVersionInfo (mkTVer targetVer) HLS dls-        when setCompile $ void $ liftE $-          setHLS targetVer SetHLSOnly Nothing-        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 $ prettyHFError err-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>-                        "Check the logs at " <> T.pack (fromGHCupPath 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 $ prettyHFError e-                pure $ ExitFailure 9-    (CompileGHC GHCCompileOptions {..}) ->-      runCompileGHC runAppState (do-        case targetGhc of-          GHC.SourceDist targetVer -> do-            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-            let vi = getVersionInfo (mkTVer 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-          _ -> pure ()-        targetVer <- liftE $ compileGHC-                    targetGhc-                    crossTarget-                    ovewrwiteVer-                    bootstrapGhc-                    jobs-                    buildConfig-                    patches-                    addConfArgs-                    buildFlavour-                    hadrian-                    (maybe GHCupInternal IsolateDir isolateDir)-        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-        let vi = getVersionInfo targetVer GHC dls-        when setCompile $ void $ liftE $-          setGHC targetVer SetGHCOnly Nothing-        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, remove it first to reinstall"-                pure ExitSuccess-              VLeft (V (DirNotEmpty fp)) -> do-                runLogger $ logError $-                  "Install directory " <> T.pack fp <> " is not empty."-                pure $ ExitFailure 3-              VLeft err@(V (BuildFailed tmpdir _)) -> do-                case keepDirs settings of-                  Never -> runLogger $ logError $ T.pack $ prettyHFError err-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>-                        "Check the logs at " <> T.pack (fromGHCupPath 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 $ prettyHFError e-                pure $ ExitFailure 9

@@ -1,261 +0,0 @@-{-# 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.Prelude-import           GHCup.Prelude.Logger-import           GHCup.Prelude.String.QQ-import           GHCup.OptParse.Common--#if !MIN_VERSION_base(4,13,0)-import           Control.Monad.Fail             ( MonadFail )-#endif-import           Control.Exception              ( displayException )-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, ParseError )-import           Options.Applicative.Help.Pretty ( text )-import           Prelude                 hiding ( appendFile )-import           System.Exit-import           URI.ByteString          hiding ( uriParser )--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 (Maybe String)-  | InitConfig-  | AddReleaseChannel Bool URI----    ----------------    --[ Parsers ]---    ------------------configP :: Parser ConfigCommand-configP = subparser-      (  command "init" initP-      <> command "set"  setP -- [set] KEY VALUE at help lhs-      <> command "show" showP-      <> command "add-release-channel" addP-      )-    <|> 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 (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))-  argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))-  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))-    (progDesc "Add a release channel from a URI")-----    ---------------    --[ Footer ]---    -----------------configFooter :: String-configFooter = [s|Examples:--  # show current config-  ghcup config--  # initialize config-  ghcup config init--  # set <key> <value> configuration pair-  ghcup config set <key> <value>|]---configSetFooter :: String-configSetFooter = [s|Examples:-  # disable caching-  ghcup config set cache false--  # switch downloader to wget-  ghcup config set downloader Wget--  # set mirror for ghcup metadata-  ghcup config set '{url-source: { OwnSource: "<url>"}}'|]----    ------------------    --[ Utilities ]---    --------------------formatConfig :: UserSettings -> String-formatConfig = UTF8.toString . Y.encode---updateSettings :: UserSettings -> UserSettings -> UserSettings-updateSettings usl usr =-   let cache'      = uCache usl      <|> uCache usr-       metaCache'  = uMetaCache usl  <|> uMetaCache usr-       metaMode'   = uMetaMode usl   <|> uMetaMode usr-       noVerify'   = uNoVerify usl   <|> uNoVerify usr-       verbose'    = uVerbose usl    <|> uVerbose usr-       keepDirs'   = uKeepDirs usl   <|> uKeepDirs usr-       downloader' = uDownloader usl <|> uDownloader usr-       urlSource'  = uUrlSource usl  <|> uUrlSource usr-       noNetwork'  = uNoNetwork usl  <|> uNoNetwork usr-       gpgSetting' = uGPGSetting usl <|> uGPGSetting usr-       platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr-       mirrors' = uMirrors usl <|> uMirrors usr-   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'- where-  updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings-  updateKeyBindings Nothing Nothing = Nothing-  updateKeyBindings (Just kbl) Nothing = Just kbl-  updateKeyBindings Nothing (Just kbr) = Just kbr-  updateKeyBindings (Just kbl) (Just kbr) =-       Just $ UserKeyBindings {-           kUp = kUp kbl <|> kUp kbr-         , kDown = kDown kbl <|> kDown kbr-         , kQuit = kQuit kbl <|> kQuit kbr-         , kInstall = kInstall kbl <|> kInstall kbr-         , kUninstall = kUninstall kbl <|> kUninstall kbr-         , kSet = kSet kbl <|> kSet kbr-         , kChangelog = kChangelog kbl <|> kChangelog kbr-         , kShowAll = kShowAll kbl <|> kShowAll kbr-         , kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr-         }----    -------------------    --[ Entrypoint ]---    --------------------data Duplicate = Duplicate     -- ^ there is a duplicate somewhere in the middle-               | NoDuplicate   -- ^ there is no duplicate-               | DuplicateLast -- ^ there's a duplicate, but it's the last element---config :: forall m. ( Monad m-          , MonadMask m-          , MonadUnliftIO m-          , MonadFail m-          )-     => ConfigCommand-     -> Settings-     -> UserSettings-     -> KeyBindings-     -> (ReaderT LeanAppState m () -> m ())-     -> m ExitCode-config configCommand settings userConf 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 mv) -> do-    r <- runE @'[JSONError, ParseError] $ do-      case mv of-        Just "" ->-          throwE $ ParseError "Empty values are not allowed"-        Nothing -> do-          usersettings <- decodeSettings k-          lift $ doConfig usersettings-          pure ()-        Just v -> do-          usersettings <- decodeSettings (k <> ": " <> v <> "\n")-          lift $ doConfig usersettings-          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--  AddReleaseChannel force uri -> do-    r <- runE @'[DuplicateReleaseChannel] $ do-      case urlSource settings of-        AddSource xs -> do-          case checkDuplicate xs (Right uri) of-            Duplicate-              | not force -> throwE (DuplicateReleaseChannel uri)-            DuplicateLast -> pure ()-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })-        GHCupURL -> do-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })-          pure ()-        OwnSource xs -> do-          case checkDuplicate xs (Right uri) of-            Duplicate-              | not force -> throwE (DuplicateReleaseChannel uri)-            DuplicateLast -> pure ()-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })-        OwnSpec spec -> do-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })-          pure ()-    case r of-      VRight _ -> do-        pure ExitSuccess-      VLeft e -> do-        runLogger $ logError $ T.pack $ prettyHFError e-        pure $ ExitFailure 15-- where-  checkDuplicate :: Eq a => [a] -> a -> Duplicate-  checkDuplicate xs a-    | last xs == a = DuplicateLast-    | a `elem` xs  = Duplicate-    | otherwise    = NoDuplicate--  -- appends the element to the end of the list, but also removes it from the existing list-  appendUnique :: Eq a => [a] -> a -> [a]-  appendUnique xs' e = go xs'-   where-    go [] = [e]-    go (x:xs)-      | x == e    =     go xs -- skip-      | otherwise = x : go xs--  doConfig :: MonadIO m => UserSettings -> m ()-  doConfig usersettings = do-    let settings' = updateSettings usersettings userConf-    path <- liftIO getConfigFilePath-    liftIO $ writeFile path $ formatConfig $ settings'-    runLogger $ logDebug $ T.pack $ show settings'-    pure ()--  decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString

@@ -1,119 +0,0 @@-{-# 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.Dirs-import           GHCup.Prelude-import           GHCup.Prelude.Logger-import           GHCup.Prelude.Process--#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 Language.Haskell.TH----    ------------------    --[ Utilities ]---    --------------------describe_result :: String-describe_result = $( LitE . StringL <$>-                     runIO (do-                             CapturedProcess{..} <-  do-                              dirs <- liftIO getAllDirs-                              let settings = AppState (defaultSettings { noNetwork = True })-                                               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 $ prettyHFError e-            pure $ ExitFailure 8

@@ -1,142 +0,0 @@-{-# 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.Prelude.Logger-import           GHCup.Prelude.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 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, UninstallFailed ]---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 (liftE rmOldGHC)-  lift $ when gcProfilingLibs rmProfilingLibs-  lift $ when gcShareDir rmShareDir-  liftE $ when gcHLSNoGHC rmHLSNoGHC-  lift $ when gcCache rmCache-  lift $ when gcTmp rmTmp-   ) >>= \case-            VRight _ -> do-                  pure ExitSuccess-            VLeft e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 27

@@ -1,538 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE TypeApplications  #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE TypeOperators     #-}--module GHCup.OptParse.Install where-----import           GHCup.OptParse.Common--import           GHCup-import           GHCup.Errors-import           GHCup.Types-import           GHCup.Utils.Dirs-import           GHCup.Prelude-import           GHCup.Prelude.Logger-import           GHCup.Prelude.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           Haskus.Utils.Variant.Excepts-import           Options.Applicative     hiding ( style )-import           Options.Applicative.Help.Pretty ( text )-import           Prelude                 hiding ( appendFile )-import           System.Exit-import           URI.ByteString          hiding ( uriParser )--import qualified Data.Text                     as T-----    -----------------    --[ Commands ]---    -------------------data InstallCommand = InstallGHC InstallOptions-                    | InstallCabal InstallOptions-                    | InstallHLS InstallOptions-                    | InstallStack InstallOptions-----    ----------------    --[ Options ]---    ------------------data InstallOptions = InstallOptions-  { instVer      :: Maybe ToolVersion-  , instBindist  :: Maybe URI-  , instSet      :: Bool-  , isolateDir   :: Maybe FilePath-  , forceInstall :: Bool-  , addConfArgs  :: [T.Text]-  }----    ----------------    --[ 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/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head|]---installOpts :: Maybe Tool -> Parser InstallOptions-installOpts tool =-  (\(u, v) b is f -> InstallOptions v u b is f)-    <$> (   (   (,)-            <$> optional-                  (option-                    (eitherReader uriParser)-                    (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help-                      "Install the specified version from this bindist"-                      <> completer (toolDlCompleter (fromMaybe GHC tool))-                    )-                  )-            <*> (Just <$> toolVersionTagArgument [] tool)-            )-        <|> pure (Nothing, Nothing)-        )-    <*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault-      (help $ if not setDefault then "Set as active version after install" else "Don't 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"-           <> completer (bashCompleter "directory")-           )-          )-    <*> switch-          (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")-    <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))- where-  setDefault = case tool of-    Nothing  -> False-    Just GHC -> False-    Just _   -> True-----    ---------------    --[ 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-                       , DayNotFound-                       , DigestError-                       , ContentLengthError-                       , GPGError-                       , DownloadFailed-                       , TarDirDoesNotExist-                       , NextVerNotFound-                       , NoToolVersionSet-                       , FileAlreadyExistsError-                       , ProcessError-                       , UninstallFailed-                       , MergeFileTreeError-                       , InstallSetError-                       ]---runInstTool :: AppState-            -> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a-            -> IO (VEither InstallEffects a)-runInstTool appstate' =-  flip runReaderT appstate'-  . runResourceT-  . runE-    @InstallEffects---type InstallGHCEffects = '[ AlreadyInstalled-                          , ArchiveResult-                          , BuildFailed-                          , CopyError-                          , DigestError-                          , ContentLengthError-                          , DirNotEmpty-                          , DownloadFailed-                          , FileAlreadyExistsError-                          , FileDoesNotExistError-                          , GPGError-                          , MergeFileTreeError-                          , NextVerNotFound-                          , NoDownload-                          , NoToolVersionSet-                          , NotInstalled-                          , ProcessError-                          , TagNotFound-                          , DayNotFound-                          , TarDirDoesNotExist-                          , UninstallFailed-                          , UnknownArchive-                          , InstallSetError-                          ]--runInstGHC :: AppState-           -> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a-           -> IO (VEither InstallGHCEffects a)-runInstGHC appstate' =-  flip runReaderT appstate'-  . runResourceT-  . runE-    @InstallGHCEffects---    --------------------    --[ 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 -> runInstGHC s' $ do-         (v, vi) <- liftE $ fromVersion instVer GHC-         liftE $ runBothE' (installGHCBin-                     v-                     (maybe GHCupInternal IsolateDir isolateDir)-                     forceInstall-                     addConfArgs-                   )-                   $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing-         pure vi-       Just uri -> do-         runInstGHC s'{ settings = settings {noVerify = True}} $ do-           (v, vi) <- liftE $ fromVersion instVer GHC-           liftE $ runBothE' (installGHCBindist-                       (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)-                       v-                       (maybe GHCupInternal IsolateDir isolateDir)-                       forceInstall-                       addConfArgs-                     )-                     $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing-           pure vi-      )-        >>= \case-              VRight vi -> do-                runLogger $ logInfo "GHC installation successful"-                forM_ (_viPostInstall =<< vi) $ \msg ->-                  runLogger $ logInfo msg-                pure ExitSuccess--              VLeft e@(V (AlreadyInstalled _ _)) -> do-                runLogger $ logWarn $ T.pack $ prettyHFError e-                pure ExitSuccess-              VLeft e@(V (AlreadyInstalled _ _)) -> do-                runLogger $ logWarn $ T.pack $ prettyHFError e-                pure ExitSuccess--              VLeft (V (DirNotEmpty fp)) -> do-                runLogger $ logError $-                  "Install directory " <> T.pack fp <> " is not empty."-                pure $ ExitFailure 3-              VLeft (V (DirNotEmpty fp)) -> do-                runLogger $ logError $-                  "Install directory " <> T.pack fp <> " is not empty."-                pure $ ExitFailure 3--              VLeft err@(V (BuildFailed tmpdir _)) -> do-                case keepDirs settings of-                  Never -> runLogger (logError $ T.pack $ prettyHFError err)-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>-                    "Check the logs at " <> T.pack (fromGHCupPath 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 err@(V (BuildFailed tmpdir _)) -> do-                case keepDirs settings of-                  Never -> runLogger (logError $ T.pack $ prettyHFError err)-                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>-                    "Check the logs at " <> T.pack (fromGHCupPath 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 $ prettyHFError e-                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)-                pure $ ExitFailure 3---  installCabal :: InstallOptions -> IO ExitCode-  installCabal InstallOptions{..} = do-    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'-    (case instBindist of-       Nothing -> runInstTool s' $ do-         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal-         liftE $ runBothE' (installCabalBin-                                    v-                                    (maybe GHCupInternal IsolateDir isolateDir)-                                    forceInstall-                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v-         pure vi-       Just uri -> do-         runInstTool s'{ settings = settings { noVerify = True}} $ do-           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal-           liftE $ runBothE' (installCabalBindist-                                      (DownloadInfo uri Nothing "" Nothing Nothing)-                                      v-                                      (maybe GHCupInternal IsolateDir isolateDir)-                                      forceInstall-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v-           pure vi-      )-      >>= \case-            VRight vi -> do-              runLogger $ logInfo "Cabal installation successful"-              forM_ (_viPostInstall =<< vi) $ \msg ->-                runLogger $ logInfo msg-              pure ExitSuccess-            VLeft e@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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 $ prettyHFError e-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)-              pure $ ExitFailure 4--  installHLS :: InstallOptions -> IO ExitCode-  installHLS InstallOptions{..} = do-     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'-     (case instBindist of-       Nothing -> runInstTool s' $ do-         (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS-         liftE $ runBothE' (installHLSBin-                                    v-                                    (maybe GHCupInternal IsolateDir isolateDir)-                                    forceInstall-                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing-         pure vi-       Just uri -> do-         runInstTool s'{ settings = settings { noVerify = True}} $ do-           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS-           -- TODO: support legacy-           liftE $ runBothE' (installHLSBindist-                                      (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)-                                      v-                                      (maybe GHCupInternal IsolateDir isolateDir)-                                      forceInstall-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing-           pure vi-      )-      >>= \case-            VRight vi -> do-              runLogger $ logInfo "HLS installation successful"-              forM_ (_viPostInstall =<< vi) $ \msg ->-                runLogger $ logInfo msg-              pure ExitSuccess-            VLeft e@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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 $ prettyHFError e-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)-              pure $ ExitFailure 4--  installStack :: InstallOptions -> IO ExitCode-  installStack InstallOptions{..} = do-     s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'-     (case instBindist of-        Nothing -> runInstTool s' $ do-          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack-          liftE $ runBothE' (installStackBin-                                     v-                                     (maybe GHCupInternal IsolateDir isolateDir)-                                     forceInstall-                                   ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v-          pure vi-        Just uri -> do-          runInstTool s'{ settings = settings { noVerify = True}} $ do-            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack-            liftE $ runBothE' (installStackBindist-                                       (DownloadInfo uri Nothing "" Nothing Nothing)-                                       v-                                       (maybe GHCupInternal IsolateDir isolateDir)-                                       forceInstall-                                     ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v-            pure vi-      )-      >>= \case-            VRight vi -> do-              runLogger $ logInfo "Stack installation successful"-              forM_ (_viPostInstall =<< vi) $ \msg ->-                runLogger $ logInfo msg-              pure ExitSuccess-            VLeft e@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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@(V (AlreadyInstalled _ _)) -> do-              runLogger $ logWarn $ T.pack $ prettyHFError e-              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 $ prettyHFError e-                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)-              pure $ ExitFailure 4

@@ -1,315 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RankNTypes #-}--module GHCup.OptParse.List where-----import           GHCup-import           GHCup.Prelude-import           GHCup.Types-import           GHCup.OptParse.Common-import           GHCup.Prelude.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.Char-import           Data.List                      ( intercalate, sort )-import           Data.Functor-import           Data.Maybe-import           Data.Time.Calendar             ( Day )-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-  , lFrom      :: Maybe Day-  , lTo        :: Maybe Day-  , lHideOld   :: Bool-  , lShowNightly :: Bool-  , 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"-              <> completer toolCompleter-            )-          )-    <*> optional-          (option-            (eitherReader criteriaParser)-            (  short 'c'-            <> long "show-criteria"-            <> metavar "<installed|set|available>"-            <> help "Apply filtering criteria, prefix with + or -"-              <> completer (listCompleter-                [ "+installed", "+set", "+available", "-installed", "-set", "-available"])-            )-          )-    <*> optional-          (option-            (eitherReader dayParser)-            (short 's' <> long "since" <> metavar "YYYY-MM-DD" <> help-              "List only tools with release date starting at YYYY-MM-DD or later"-              <> completer toolCompleter-            )-          )-    <*> optional-          (option-            (eitherReader dayParser)-            (short 'u' <> long "until" <> metavar "YYYY-MM-DD" <> help-              "List only tools with release date earlier than YYYY-MM-DD"-              <> completer toolCompleter-            )-          )-    <*> switch-          (short 'o' <> long "hide-old" <> help "Hide 'old' GHC versions (installed ones are always shown)"-          )-    <*> switch-          (short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)"-          )-    <*> switch-          (short 'r' <> long "raw-format" <> help "More machine-parsable format"-          )---    ---------------    --[ Footer ]---    -----------------listToolFooter :: String-listToolFooter = [s|Discussion:-  Lists tool versions with optional criteria.-  Nightlies are by default hidden.--Examples:-  # query nightlies in a specific range-  ghcup list --show-nightly --since 2022-12-07 --until 2022-12-31-  # show all installed GHC versions-  ghcup list -t ghc -c installed|]---    ------------------    --[ 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 Nightly            = color Red "nightly"-    printTag (Base       pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')-    printTag (UnknownTag t    ) = t-    printTag LatestPrerelease   = color Red "latest-prerelease"-    printTag LatestNightly      = color Red "latest-nightly"-    printTag Old                = ""--  let-    rows =-      (\x -> if raw-          then x-          else [color Green "", "Tool", "Version", "Tags", "Notes"] : x-        )-        . fmap-            (\ListResult {..} ->-              let marks = if-                    | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))-                    | lInstalled -> (color Green (if isWindows then "I " else "✓ "))-                    | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))-              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)-                     ++ (case lReleaseDay of-                           Nothing -> mempty-                           Just d  -> [color Blue (show d)])-                     ++ (if lNoBindist-                          then [color Red "no-bindist"]-                          else mempty-                        )-                     ]-            )-        $ lr-  let cols =-        foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows-      lengths = fmap (maximum . fmap strWidth) cols-      padded  = fmap (\xs -> zipWith padTo xs lengths) rows--  forM_ (if raw then rows else 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 (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo)-      liftIO $ printListResult no_color lRawFormat l-      pure ExitSuccess-    )

@@ -1,98 +0,0 @@-{-# 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.Prelude.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 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, UninstallFailed ]---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 [ListInstalled True] False True (Nothing, Nothing)--       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 $ prettyHFError e-                  pure $ ExitFailure 15

@@ -1,220 +0,0 @@-{-# 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.Prelude.File-import           GHCup.Prelude.Logger-import           GHCup.Prelude.String.QQ-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.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 Control.Exception.Safe (MonadMask)-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/)" <> completer (bashCompleter "directory"))))-          <*>  optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))-          <*> ( optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))-          <*> ( optional (toolVersionTagArgument [] (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/)" <> completer (bashCompleter "directory"))))-          <*> ( optional (toolVersionTagArgument [] (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-                        , DayNotFound-                        , NextVerNotFound-                        , NoToolVersionSet-                        , NoDownload-                        , DigestError-                        , ContentLengthError-                        , 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 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 $ prettyHFError e-                  pure $ ExitFailure 15

@@ -1,231 +0,0 @@-{-# 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.Prelude.Logger-import           GHCup.Prelude.String.QQ-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.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 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' [ListInstalled True] (Just Cabal) <**> helper)-                    (progDesc "Remove Cabal version")-           )-      <> command-           "hls"-           (   RmHLS-           <$> info (versionParser' [ListInstalled True] (Just HLS) <**> helper)-                    (progDesc "Remove haskell-language-server version")-           )-      <> command-           "stack"-           (   RmStack-           <$> info (versionParser' [ListInstalled True] (Just Stack) <**> helper)-                    (progDesc "Remove stack version")-           )-      )-    )-    <|> (Right <$> rmOpts Nothing)----rmOpts :: Maybe Tool -> Parser RmOptions-rmOpts tool = RmOptions <$> ghcVersionArgument [ListInstalled True] 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, UninstallFailed ]---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 ghcVer GHC dls)-      )-      >>= \case-            VRight vi -> do-              runLogger $ logGHCPostRm ghcVer-              postRmLog vi-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 7--  rmCabal' tv =-    runRm runAppState (do-        liftE $-          rmCabalVer tv-        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-        pure (getVersionInfo (mkTVer tv) Cabal dls)-      )-      >>= \case-            VRight vi -> do-              postRmLog vi-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 15--  rmHLS' tv =-    runRm runAppState (do-        liftE $-          rmHLSVer tv-        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-        pure (getVersionInfo (mkTVer tv) HLS dls)-      )-      >>= \case-            VRight vi -> do-              postRmLog vi-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 15--  rmStack' tv =-    runRm runAppState (do-        liftE $-          rmStackVer tv-        GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-        pure (getVersionInfo (mkTVer tv) Stack dls)-      )-      >>= \case-            VRight vi -> do-              postRmLog vi-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 15--  postRmLog vi =-    forM_ (_viPostRemove =<< vi) $ \msg ->-      runLogger $ logInfo msg

@@ -1,495 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TypeApplications  #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE ViewPatterns      #-}-module GHCup.OptParse.Run where---import           GHCup-import           GHCup.Utils-import           GHCup.OptParse.Common-import           GHCup.Errors-import           GHCup.Types-import           GHCup.Types.Optics-import           GHCup.Prelude-import           GHCup.Prelude.File-#ifdef IS_WINDOWS-import           GHCup.Prelude.Process-import           GHCup.Prelude.Process.Windows ( execNoMinGW )-#endif-import           GHCup.Prelude.Logger-import           GHCup.Prelude.String.QQ--import           Control.Exception.Safe         ( MonadMask, MonadCatch )-#if !MIN_VERSION_base(4,13,0)-import           Control.Monad.Fail             ( MonadFail )-#endif-import           Codec.Archive-import           Control.Monad.Reader-import           Control.Monad.Trans.Resource-import           Data.Functor-import           Data.Maybe (isNothing)-import           Data.List                      ( intercalate )-import           Haskus.Utils.Variant.Excepts-import           Options.Applicative     hiding ( style )-import           Prelude                 hiding ( appendFile )-import           System.FilePath-import           System.Environment-import           System.Exit--import qualified Data.Map.Strict               as Map-import qualified Data.Text                     as T-#ifndef IS_WINDOWS-import qualified System.Posix.Process          as SPP-#endif-import Data.Versions ( prettyVer, Version )------    ----------------    --[ Options ]---    ------------------data RunOptions = RunOptions-  { runAppendPATH :: Bool-  , runInstTool'  :: Bool-  , runMinGWPath  :: Bool-  , runGHCVer     :: Maybe ToolVersion-  , runCabalVer   :: Maybe ToolVersion-  , runHLSVer     :: Maybe ToolVersion-  , runStackVer   :: Maybe ToolVersion-  , runBinDir     :: Maybe FilePath-  , runQuick      :: Bool-  , runCOMMAND    :: [String]-  }----    ----------------    --[ Parsers ]---    -------------------runOpts :: Parser RunOptions-runOpts =-  RunOptions-    <$> switch-          (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")-    <*> switch-          (short 'i' <> long "install" <> help "Install the tool, if missing")-    <*> switch-          (short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")-    <*> optional-          (option-            (eitherReader ghcVersionTagEither)-            (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"-            <> completer (tagCompleter GHC [])-            <> (completer $ versionCompleter [] GHC)-            )-          )-    <*> optional-          (option-            (eitherReader toolVersionTagEither)-            (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"-            <> completer (tagCompleter Cabal [])-            <> (completer $ versionCompleter [] Cabal)-            )-          )-    <*> optional-          (option-            (eitherReader toolVersionTagEither)-            (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"-            <> completer (tagCompleter HLS [])-            <> (completer $ versionCompleter [] HLS)-            )-          )-    <*> optional-          (option-            (eitherReader toolVersionTagEither)-            (metavar "STACK_VERSION" <> long "stack" <> help "The stack version"-            <> completer (tagCompleter Stack [])-            <> (completer $ versionCompleter [] Stack)-            )-          )-    <*> optional-          (option-           (eitherReader isolateParser)-           (  short 'b'-           <> long "bindir"-           <> metavar "DIR"-           <> help "directory where to create the tool symlinks (default: newly created system temp dir)"-           <> completer (bashCompleter "directory")-           )-          )-    <*> switch-          (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")-    <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))-----    ---------------    --[ Footer ]---    -----------------runFooter :: String-runFooter = [s|Discussion:-  Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing-  the relevant binaries, then executes a command.--Examples:-  # run VSCode with all latest toolchain exposed, installing missing versions if necessary-  ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs--  # create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH-  ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin--  # run a specific ghc version-  ghcup run --ghc 8.10.7 -- ghc --version|]-----    ----------------------------    --[ Effect interpreters ]---    ------------------------------type RunEffects = '[ AlreadyInstalled-                   , UnknownArchive-                   , ArchiveResult-                   , FileDoesNotExistError-                   , CopyError-                   , NotInstalled-                   , DirNotEmpty-                   , NoDownload-                   , NotInstalled-                   , BuildFailed-                   , TagNotFound-                   , DayNotFound-                   , DigestError-                   , ContentLengthError-                   , GPGError-                   , DownloadFailed-                   , TarDirDoesNotExist-                   , NextVerNotFound-                   , NoToolVersionSet-                   , FileAlreadyExistsError-                   , ProcessError-                   , UninstallFailed-                   , MergeFileTreeError-                   ]--runLeanRUN :: (MonadUnliftIO m, MonadIO m)-           => LeanAppState-           -> Excepts RunEffects (ReaderT LeanAppState m) a-           -> m (VEither RunEffects a)-runLeanRUN 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-      @RunEffects--runRUN :: MonadUnliftIO m-      => IO AppState-      -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a-      -> m (VEither RunEffects a)-runRUN appState action' = do-  s' <- liftIO appState-  flip runReaderT s'-    . runResourceT-    . runE-      @RunEffects-    $ action'----    -------------------    --[ Entrypoint ]---    ----------------------run :: forall m .-       ( MonadFail m-       , MonadMask m-       , MonadCatch m-       , MonadIO m-       , MonadUnliftIO m-       )-   => RunOptions-   -> IO AppState-   -> LeanAppState-   -> (ReaderT LeanAppState m () -> m ())-   -> m ExitCode-run RunOptions{..} runAppState leanAppstate runLogger = do-   r <- if not runQuick-        then runRUN runAppState $ do-         toolchain <- liftE resolveToolchainFull--         -- oh dear-         r <- lift ask-         tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain--         liftE $ installToolChainFull toolchain tmp-         pure tmp-        else runLeanRUN leanAppstate $ do-         toolchain <- resolveToolchain-         tmp <- lift $ createTmpDir toolchain-         liftE $ installToolChain toolchain tmp-         pure tmp-   case r of-         VRight tmp -> do-           case runCOMMAND of-             [] -> do-               liftIO $ putStr tmp-               pure ExitSuccess-             (cmd:args) -> do-               newEnv <- liftIO $ addToPath tmp runAppendPATH-#ifndef IS_WINDOWS-               void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)-               pure ExitSuccess-#else-               r' <- if runMinGWPath-                     then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)-                     else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)-               case r' of-                 VRight _ -> pure ExitSuccess-                 VLeft e -> do-                   runLogger $ logError $ T.pack $ prettyHFError e-                   pure $ ExitFailure 28-#endif-         VLeft e -> do-           runLogger $ logError $ T.pack $ prettyHFError e-           pure $ ExitFailure 27--  where--   -- TODO: doesn't work for cross-   resolveToolchainFull :: ( MonadFail m-                           , MonadThrow m-                           , MonadIO m-                           , MonadCatch m-                           )-                        => Excepts-                             '[ TagNotFound-                              , DayNotFound-                              , NextVerNotFound-                              , NoToolVersionSet-                              ] (ResourceT (ReaderT AppState m)) Toolchain-   resolveToolchainFull = do-         ghcVer <- forM runGHCVer $ \ver -> do-           (v, _) <- liftE $ fromVersion (Just ver) GHC-           pure v-         cabalVer <- forM runCabalVer $ \ver -> do-           (v, _) <- liftE $ fromVersion (Just ver) Cabal-           pure (_tvVersion v)-         hlsVer <- forM runHLSVer $ \ver -> do-           (v, _) <- liftE $ fromVersion (Just ver) HLS-           pure (_tvVersion v)-         stackVer <- forM runStackVer $ \ver -> do-           (v, _) <- liftE $ fromVersion (Just ver) Stack-           pure (_tvVersion v)-         pure Toolchain{..}--   resolveToolchain = do-         ghcVer <- case runGHCVer of-            Just (GHCVersion v) -> pure $ Just v-            Just (ToolVersion v) -> pure $ Just (mkTVer v)-            Nothing -> pure Nothing-            _ -> fail "Internal error"-         cabalVer <- case runCabalVer of-            Just (GHCVersion v) -> pure $ Just (_tvVersion v)-            Just (ToolVersion v) -> pure $ Just v-            Nothing -> pure Nothing-            _ -> fail "Internal error"-         hlsVer <- case runHLSVer of-            Just (GHCVersion v) -> pure $ Just (_tvVersion v)-            Just (ToolVersion v) -> pure $ Just v-            Nothing -> pure Nothing-            _ -> fail "Internal error"-         stackVer <- case runStackVer of-            Just (GHCVersion v) -> pure $ Just (_tvVersion v)-            Just (ToolVersion v) -> pure $ Just v-            Nothing -> pure Nothing-            _ -> fail "Internal error"-         pure Toolchain{..}--   installToolChainFull :: ( MonadFail m-                           , MonadThrow m-                           , MonadIO m-                           , MonadCatch m-                           )-                        => Toolchain-                        -> FilePath-                        -> Excepts-                             '[ TagNotFound-                              , DayNotFound-                              , NextVerNotFound-                              , NoToolVersionSet-                              , UnknownArchive-                              , TarDirDoesNotExist-                              , ProcessError-                              , NotInstalled-                              , NoDownload-                              , GPGError-                              , DownloadFailed-                              , DirNotEmpty-                              , DigestError-                              , ContentLengthError-                              , BuildFailed-                              , ArchiveResult-                              , AlreadyInstalled-                              , FileAlreadyExistsError-                              , CopyError-                              , UninstallFailed-                              , MergeFileTreeError-                              ] (ResourceT (ReaderT AppState m)) ()-   installToolChainFull Toolchain{..} tmp = do-         case ghcVer of-           Just v -> do-             isInstalled <- lift $ checkIfToolInstalled' GHC v-             unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin-               v-               GHCupInternal-               False-               []-             setGHC' v tmp-           _ -> pure ()-         case cabalVer of-           Just v -> do-             isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)-             unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin-               v-               GHCupInternal-               False-             setCabal' v tmp-           _ -> pure ()-         case stackVer of-           Just v -> do-             isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)-             unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin-               v-               GHCupInternal-               False-             setStack' v tmp-           _ -> pure ()-         case hlsVer of-           Just v -> do-             isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)-             unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin-               v-               GHCupInternal-               False-             setHLS' v tmp-           _ -> pure ()--   installToolChain :: ( MonadFail m-                       , MonadThrow m-                       , MonadIO m-                       , MonadCatch m-                       )-                    => Toolchain-                    -> FilePath-                    -> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()-   installToolChain Toolchain{..} tmp = do-         case ghcVer of-           Just v -> setGHC' v tmp-           _ -> pure ()-         case cabalVer of-           Just v -> setCabal' v tmp-           _ -> pure ()-         case stackVer of-           Just v -> setStack' v tmp-           _ -> pure ()-         case hlsVer of-           Just v -> setHLS' v tmp-           _ -> pure ()--   setGHC' v tmp = do-          void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)-          void $ liftE $ setGHC v SetGHCOnly (Just tmp)-   setCabal' v tmp = do-          bin  <- liftE $ whereIsTool Cabal (mkTVer v)-          cbin <- liftIO $ canonicalizePath bin-          lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))-   setStack' v tmp = do-          bin  <- liftE $ whereIsTool Stack (mkTVer v)-          cbin <- liftIO $ canonicalizePath bin-          lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))-   setHLS' v tmp = do-          Dirs {..}  <- getDirs-          legacy <- isLegacyHLS v-          if legacy-          then do-            -- TODO: factor this out-            hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v))-            cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)-            lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)-            hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))-            forM_ hlsBins $ \bin ->-              lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)-            liftE $ setHLS v SetHLSOnly (Just tmp)-          else do-            liftE $ setHLS v SetHLS_XYZ (Just tmp)-            liftE $ setHLS v SetHLSOnly (Just tmp)--   createTmpDir :: ( MonadUnliftIO m-                   , MonadCatch m-                   , MonadThrow m-                   , MonadMask m-                   , MonadIO m-                   )-                => Toolchain-                -> ReaderT LeanAppState m FilePath-   createTmpDir toolchain =-     case runBinDir of-           Just bindir -> do-             liftIO $ createDirRecursive' bindir-             liftIO $ canonicalizePath bindir-           Nothing -> do-             d <- predictableTmpDir toolchain-             liftIO $ createDirRecursive' d-             liftIO $ canonicalizePath d--   predictableTmpDir :: Monad m-                     => Toolchain-                     -> ReaderT LeanAppState m FilePath-   predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do-     Dirs { tmpDir } <- getDirs-     pure (fromGHCupPath tmpDir </> "ghcup-none")-   predictableTmpDir Toolchain{..} = do-      Dirs { tmpDir } <- getDirs-      pure $ fromGHCupPath tmpDir-        </> ("ghcup-" <> intercalate "_"-              (  maybe [] ( (:[]) . ("ghc-"   <>) . T.unpack . tVerToText) ghcVer-              <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer-              <> maybe [] ( (:[]) . ("hls-"   <>) . T.unpack . prettyVer) hlsVer-              <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer-              )-            )----    --------------------------    --[ Other local types ]---    -----------------------------data Toolchain = Toolchain-  { ghcVer     :: Maybe GHCTargetVersion-  , cabalVer   :: Maybe Version-  , hlsVer     :: Maybe Version-  , stackVer   :: Maybe Version-  } deriving Show

@@ -1,343 +0,0 @@-{-# 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.Prelude.Logger-import           GHCup.Prelude.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 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 GHC <**> helper)-                (  progDesc "Set GHC version"-                <> footerDoc (Just $ text setGHCFooter)-                )-          )-      <> command-           "cabal"-           (   SetCabal-           <$> info-                 (setOpts Cabal <**> helper)-                 (  progDesc "Set Cabal version"-                 <> footerDoc (Just $ text setCabalFooter)-                 )-           )-      <> command-           "hls"-           (   SetHLS-           <$> info-                 (setOpts HLS <**> helper)-                 (  progDesc "Set haskell-language-server version"-                 <> footerDoc (Just $ text setHLSFooter)-                 )-           )-      <> command-           "stack"-           (   SetStack-           <$> info-                 (setOpts Stack <**> helper)-                 (  progDesc "Set stack version"-                 <> footerDoc (Just $ text setStackFooter)-                 )-           )-      )-    )-    <|> (Right <$> setOpts GHC)- 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 :: Tool -> Parser SetOptions-setOpts tool = SetOptions <$>-    (fromMaybe SetRecommended <$>-      optional (setVersionArgument [ListInstalled True] tool))--setVersionArgument :: [ListCriteria] -> Tool -> Parser SetToolVersion-setVersionArgument criteria tool =-  argument (eitherReader setEither)-    (metavar "VERSION|TAG|next"-    <> completer (tagCompleter tool ["next"])-    <> (completer . versionCompleter criteria) tool)- where-  setEither s' =-        parseSet s'-    <|> second SetToolTag (tagEither s')-    <|> se s'-  se s' = case tool of-           GHC -> second SetGHCVersion (ghcVersionEither s')-           _   -> second SetToolVersion (toolVersionEither 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-                   , DayNotFound-                   , 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-                        , DayNotFound-                        , 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-                      , DayNotFound-                      , 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-                        , DayNotFound-                        , 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 _ 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 } = runSetGHC runAppState (do-          v <- liftE $ fst <$> fromVersion' sToolVer GHC-          liftE $ setGHC v SetGHCOnly Nothing-        )-      >>= \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 $ prettyHFError e-              pure $ ExitFailure 5---  setCabal' :: SetOptions-            -> m ExitCode-  setCabal' SetOptions{ sToolVer } = runSetCabal runAppState (do-          v <- liftE $ fst <$> fromVersion' sToolVer Cabal-          liftE $ setCabal (_tvVersion v)-          pure v-        )-      >>= \case-            VRight v -> do-              runLogger-                $ logInfo $-                    "Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 14--  setHLS' :: SetOptions-          -> m ExitCode-  setHLS' SetOptions{ sToolVer } = runSetHLS runAppState (do-          v <- liftE $ fst <$> fromVersion' sToolVer HLS-          liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing-          pure v-        )-      >>= \case-            VRight v -> do-              runLogger-                $ logInfo $-                    "HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 14---  setStack' :: SetOptions-            -> m ExitCode-  setStack' SetOptions{ sToolVer } = runSetStack runAppState (do-            v <- liftE $ fst <$> fromVersion' sToolVer Stack-            liftE $ setStack (_tvVersion v)-            pure v-          )-      >>= \case-            VRight v -> do-              runLogger-                $ logInfo $-                    "Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"-              pure ExitSuccess-            VLeft  e -> do-              runLogger $ logError $ T.pack $ prettyHFError e-              pure $ ExitFailure 14

@@ -1,189 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE TypeApplications  #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE TypeOperators     #-}--module GHCup.OptParse.Test where-----import           GHCup.OptParse.Common--import           GHCup-import           GHCup.Errors-import           GHCup.Types-import           GHCup.Utils.Dirs-import           GHCup.Prelude.Logger-import           GHCup.Prelude.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.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           URI.ByteString          hiding ( uriParser )--import qualified Data.Text                     as T-----    -----------------    --[ Commands ]---    -------------------data TestCommand = TestGHC TestOptions-----    ----------------    --[ Options ]---    ------------------data TestOptions = TestOptions-  { testVer      :: Maybe ToolVersion-  , testBindist  :: Maybe URI-  , addMakeArgs  :: [T.Text]-  }----    ----------------    --[ Footers ]---    -----------------testFooter :: String-testFooter = [s|Discussion:-  Runs test suites from the test bindist.|]-----    ----------------    --[ Parsers ]---    -----------------testParser :: Parser TestCommand-testParser =-  subparser-      (  command-          "ghc"-          (   TestGHC-          <$> info-                (testOpts (Just GHC) <**> helper)-                (  progDesc "Test GHC"-                <> footerDoc (Just $ text testGHCFooter)-                )-          )-        )- where-  testGHCFooter :: String-  testGHCFooter = [s|Discussion:-  Runs the GHC test suite from the test bindist.|]---testOpts :: Maybe Tool -> Parser TestOptions-testOpts tool =-  (\(u, v) args -> TestOptions v u args)-    <$> (   (   (,)-            <$> optional-                  (option-                    (eitherReader uriParser)-                    (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help-                      "Install the specified version from this bindist"-                      <> completer (toolDlCompleter (fromMaybe GHC tool))-                    )-                  )-            <*> (Just <$> toolVersionTagArgument [] tool)-            )-        <|> pure (Nothing, Nothing)-        )-    <*> many (argument str (metavar "MAKE_ARGS" <> help "Additional arguments to 'make', prefix with '-- ' (longopts)"))--------    ----------------------------    --[ Effect interpreters ]---    ------------------------------type TestGHCEffects = [ DigestError-                      , ContentLengthError-                      , GPGError-                      , DownloadFailed-                      , NoDownload-                      , ArchiveResult-                      , TarDirDoesNotExist-                      , UnknownArchive-                      , TestFailed-                      , NextVerNotFound-                      , TagNotFound-                      , DayNotFound-                      , NoToolVersionSet-                      ]--runTestGHC :: AppState-           -> Excepts TestGHCEffects (ResourceT (ReaderT AppState IO)) a-           -> IO (VEither TestGHCEffects a)-runTestGHC appstate' =-  flip runReaderT appstate'-  . runResourceT-  . runE-    @TestGHCEffects---    --------------------    --[ Entrypoints ]---    ----------------------test :: TestCommand -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode-test testCommand settings getAppState' runLogger = case testCommand of-  (TestGHC iopts) -> go iopts- where-  go :: TestOptions -> IO ExitCode-  go TestOptions{..} = do-    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'-    (case testBindist of-       Nothing -> runTestGHC s' $ do-         (v, vi) <- liftE $ fromVersion testVer GHC-         liftE $ testGHCVer v addMakeArgs-         pure vi-       Just uri -> do-         runTestGHC s'{ settings = settings {noVerify = True}} $ do-           (v, vi) <- liftE $ fromVersion testVer GHC-           liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) v addMakeArgs-           pure vi-      )-        >>= \case-              VRight _ -> do-                runLogger $ logInfo "GHC test successful"-                pure ExitSuccess-              VLeft e -> do-                runLogger $ do-                  logError $ T.pack $ prettyHFError e-                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)-                pure $ ExitFailure 3-

@@ -1,121 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE TypeApplications  #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE QuasiQuotes #-}--module GHCup.OptParse.ToolRequirements where---import           GHCup.Errors-import           GHCup.Types-import           GHCup.Prelude.Logger-import           GHCup.Prelude.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           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.Text.IO                  as T-import Control.Exception.Safe (MonadMask)-import GHCup.Types.Optics-import GHCup.Platform-import GHCup.Prelude-import GHCup.Requirements-import System.IO----    ----------------    --[ Options ]---    ------------------data ToolReqOpts = ToolReqOpts-  { tlrRaw :: Bool-  }-----    ----------------    --[ Parsers ]---    -----------------          -toolReqP :: Parser ToolReqOpts-toolReqP =-  ToolReqOpts-    <$> switch (short 'r' <> long "raw-format" <> help "machine-parsable format")-----    ---------------    --[ Footer ]---    -----------------toolReqFooter :: String-toolReqFooter = [s|Discussion:-  Print tool requirements on the current platform.-  If you want to pass this to your package manage, use '--raw-format'.|]----    ----------------------------    --[ 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-                    )-                 => ToolReqOpts-                 -> (ReaderT AppState m (VEither ToolRequirementsEffects ()) -> m (VEither ToolRequirementsEffects ()))-                 -> (ReaderT LeanAppState m () -> m ())-                 -> m ExitCode-toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements runAppState (do-    GHCupInfo { .. } <- lift getGHCupInfo-    platform' <- liftE getPlatform-    req       <- getCommonRequirements platform' _toolRequirements ?? NoToolRequirements-    if tlrRaw-    then liftIO $ T.hPutStr stdout (rawRequirements req)-    else liftIO $ T.hPutStr stdout (prettyRequirements req)-  )-    >>= \case-          VRight _ -> pure ExitSuccess-          VLeft  e -> do-            runLogger $ logError $ T.pack $ prettyHFError e-            pure $ ExitFailure 12

@@ -1,204 +0,0 @@-{-# 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.Prelude.Logger-import           GHCup.Prelude.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 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 $ prettyHFError 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

@@ -1,155 +0,0 @@-{-# 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.Prelude.File-import           GHCup.Prelude.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 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"-      )-    <|>-      (   UpgradeAt-        <$> option-              str-              (short 't' <> long "target" <> metavar "TARGET_DIR" <> help-                "Absolute filepath to write ghcup into"-                <> completer (bashCompleter "file")-              )-        )-    <|> pure UpgradeGHCupDir-----    ----------------------------    --[ Effect interpreters ]---    ------------------------------type UpgradeEffects = '[ DigestError-                       , ContentLengthError-                       , GPGError-                       , NoDownload-                       , NoUpdate-                       , FileDoesNotExistError-                       , CopyError-                       , DownloadFailed-                       , ToolShadowed-                       ]---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-        -> Bool-        -> Dirs-        -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))-        -> (ReaderT LeanAppState m () -> m ())-        -> m ExitCode-upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do-  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' fatal-    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 $ prettyHFError e-        pure $ ExitFailure 11

@@ -1,342 +0,0 @@-{-# 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-import           GHCup.Prelude.Logger-import           GHCup.Prelude.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.Environment-import           System.Exit--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 (toolVersionTagArgument [] (Just GHC)) <**> helper )-        ( progDesc "Get GHC location"-        <> footerDoc (Just $ text whereisGHCFooter ))-      )-      <>-     command-      "cabal"-      (WhereisTool Cabal <$> info-        ( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper )-        ( progDesc "Get cabal location"-        <> footerDoc (Just $ text whereisCabalFooter ))-      )-      <>-     command-      "hls"-      (WhereisTool HLS <$> info-        ( optional (toolVersionTagArgument [] (Just HLS)) <**> helper )-        ( progDesc "Get HLS location"-        <> footerDoc (Just $ text whereisHLSFooter ))-      )-      <>-     command-      "stack"-      (WhereisTool Stack <$> info-        ( optional (toolVersionTagArgument [] (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-                , DayNotFound-                ]---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 GHCup _, WhereisOptions{..}) -> do-      loc <- liftIO (getExecutablePath >>= canonicalizePath )-      if directory-      then liftIO $ putStr $ takeDirectory loc-      else liftIO $ putStr loc-      pure ExitSuccess--    (WhereisTool tool (Just (GHCVersion 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 $ prettyHFError e-                pure $ ExitFailure 30-    (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->-      runLeanWhereIs leanAppstate (do-        loc <- liftE $ whereIsTool tool (mkTVer 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 $ prettyHFError 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 $ prettyHFError e-                pure $ ExitFailure 30--    (WhereisBaseDir, _) -> do-      liftIO $ putStr $ fromGHCupPath baseDir-      pure ExitSuccess--    (WhereisBinDir, _) -> do-      liftIO $ putStr binDir-      pure ExitSuccess--    (WhereisCacheDir, _) -> do-      liftIO $ putStr $ fromGHCupPath cacheDir-      pure ExitSuccess--    (WhereisLogsDir, _) -> do-      liftIO $ putStr $ fromGHCupPath logsDir-      pure ExitSuccess--    (WhereisConfDir, _) -> do-      liftIO $ putStr $ fromGHCupPath confDir-      pure ExitSuccess

@@ -42,7 +42,6 @@ import           Data.Either import           Data.Functor import           Data.Maybe-import           Data.Versions import           GHC.IO.Encoding import           Haskus.Utils.Variant.Excepts import           Language.Haskell.TH@@ -85,7 +84,7 @@          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings-         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource+         urlSource   = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg          platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)@@ -211,10 +210,9 @@                                             exitWith (ExitFailure 2)                  ghcupInfo <--                  ( flip runReaderT leanAppstate-                    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]-                    $ liftE getDownloadsF-                    )+                  ( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do+                     liftE $ getDownloadsF pfreq+                  )                     >>= \case                           VRight r -> pure r                           VLeft  e -> do@@ -341,9 +339,9 @@                           ] m Bool   alreadyInstalling (Install (Right InstallOptions{..}))                 (GHC, ver)   = cmp' GHC instVer ver   alreadyInstalling (Install (Left (InstallGHC InstallOptions{..})))     (GHC, ver)   = cmp' GHC instVer ver-  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver) = cmp' Cabal instVer ver-  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)   = cmp' HLS instVer ver-  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver) = cmp' Stack instVer ver+  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver)    = cmp' Cabal instVer ver+  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)      = cmp' HLS instVer ver+  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver)    = cmp' Stack instVer ver   alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))     (GHC, ver)   = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver   alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))@@ -378,3 +376,4 @@   cmp' tool instVer ver = do     (v, _) <- liftE $ fromVersion instVer tool     pure (v == ver)+

@@ -16,6 +16,11 @@ # TUI key bindings, # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key # for possible values.+# It's also possible to define key+modifier, e.g.:+#   quit:+#     Key:+#       KChar: c+#     Mods: [MCtrl] key-bindings:   up:     KUp: []@@ -46,41 +51,45 @@ #   2. Strict: fail hard meta-mode: Lax # Strict | Lax -# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation-# check the 'URLSource' type in the code.+# Where to get GHC/cabal/hls download info/versions from. This is a list that performs+# union over tool versions, preferring the later entries. url-source:   ## Use the internal download uri, this is the default-  GHCupURL: []+  - GHCupURL -  ## Example 1: Read download info from this location instead-  ## Accepts file/http/https scheme-  ## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in-  ## which case they are merged right-biased (overwriting duplicate versions).-  # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"+  ## Prefer stack supplied metadata (will still use GHCup metadata for versions not existing in stack metadata)+  # - StackSetupURL -  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.-  ## Can also be an array of 'Either GHCupInfo URL', also see Example 3.-  # AddSource:-    # Left:-      # globalTools: {}-      # toolRequirements: {}-      # ghcupDownloads:-        # GHC:-          # 9.10.2:-            # viTags: []-            # viArch:-              # A_64:-                # Linux_UnknownLinux:-                  # unknown_versioning:-                    # dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2-                    # dlSubdir: ghc-7.10.3-                    # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5+  ## Add pre-release channel+  # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml+  ## Add nightly channel+  # - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml+  ## Add cross compiler channel+  # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml -  ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate-  ## versions).-  # AddSource:-    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"-    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"+  ## Use dwarf bindist for 9.4.7 for ghcup metadata+  # - ghcup-info:+  #     ghcupDownloads:+  #       GHC:+  #         9.4.7:+  #           viTags: []+  #           viArch:+  #             A_64:+  #               Linux_UnknownLinux:+  #                 unknown_versioning:+  #                   dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz+  #                   dlSubdir:+  #                     RegexDir: "ghc-.*"+  #                   dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4++  ## for stack metadata and the linux64-tinfo6 bindists, use static alpine for 9.8.1+  # - setup-info:+  #     ghc:+  #       linux64-tinfo6:+  #         9.8.1:+  #           url: "https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-alpine3_12-linux-static.tar.xz"+  #           content-length: 229037440+  #           sha256: b48f3d3a508d0c140d1c801e04afc65e80c0d25e7e939a8a41edb387b26b81b3  # This is a way to override platform detection, e.g. when you're running # a Ubuntu derivate based on 18.04, you could do:

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               ghcup-version:            0.1.19.5+version:            0.1.20.0 license:            LGPL-3.0-only license-file:       LICENSE copyright:          Julian Ospald 2020@@ -25,10 +25,10 @@   cbits/dirutils.h   data/build_mk/cross   data/build_mk/default-  test/data/dir/.keep-  test/data/file-  test/golden/unix/GHCupInfo.json-  test/golden/windows/GHCupInfo.json+  test/ghcup-test/data/dir/.keep+  test/ghcup-test/data/file+  test/ghcup-test/golden/unix/GHCupInfo.json+  test/ghcup-test/golden/windows/GHCupInfo.json  source-repository head   type:     git@@ -36,7 +36,7 @@  flag tui   description:-    Build the brick powered tui (ghcup tui). This is disabled on windows.+    Build the brick powered tui (ghcup tui).    default:     False   manual:      True@@ -53,6 +53,43 @@   default:     False   manual:      True +common app-common-depends+  build-depends:+    , aeson                  >=1.4+    , aeson-pretty           ^>=0.8.8+    , async                  ^>=2.2.3+    , base                   >=4.12     && <5+    , bytestring             >=0.10     && <0.12+    , cabal-install-parsers  >=0.4.5+    , cabal-plan             ^>=0.7.2+    , containers             ^>=0.6+    , deepseq                ^>=1.4+    , directory              ^>=1.3.6.0+    , filepath               ^>=1.4.2.1+    , haskus-utils-types     ^>=1.5+    , haskus-utils-variant   ^>=3.2.1+    , libarchive             ^>=3.0.3.0+    , megaparsec             >=8.0.0    && <9.3+    , mtl                    ^>=2.2+    , optparse-applicative   >=0.15.1.0 && <0.18+    , pretty                 ^>=1.1.3.1+    , pretty-terminal        ^>=0.1.0.0+    , process                ^>=1.6.11.0+    , resourcet              ^>=1.2.2+    , safe                   ^>=0.3.18+    , safe-exceptions        ^>=0.1+    , tagsoup                ^>=0.14+    , template-haskell       >=2.7      && <2.20+    , temporary              ^>=1.3+    , text                   ^>=2.0+    , time                   >=1.9.3    && <1.12+    , unordered-containers   ^>=0.2+    , uri-bytestring         ^>=0.3.2.2+    , utf8-string            ^>=1.0+    , vector                 >=0.12     && <0.14+    , versions               >=6.0.3    && <6.1+    , yaml-streamly          ^>=0.12.0+ library   exposed-modules:     GHCup@@ -80,7 +117,9 @@     GHCup.Types     GHCup.Types.JSON     GHCup.Types.JSON.Utils+    GHCup.Types.JSON.Versions     GHCup.Types.Optics+    GHCup.Types.Stack     GHCup.Utils     GHCup.Utils.Dirs     GHCup.Version@@ -137,7 +176,7 @@     , pretty-terminal       ^>=0.1.0.0     , regex-posix           ^>=0.96     , resourcet             ^>=1.2.2-    , retry                 ^>=0.8.1.2 || ^>=0.9+    , retry                 >=0.8.1.2    && <0.10     , safe                  ^>=0.3.18     , safe-exceptions       ^>=0.1     , split                 ^>=0.2.3.4@@ -146,13 +185,13 @@     , template-haskell      >=2.7        && <2.20     , temporary             ^>=1.3     , text                  ^>=2.0-    , time                  ^>=1.9.3 || ^>=1.10 || ^>=1.11+    , time                  >=1.9.3      && <1.12     , transformers          ^>=0.5     , unliftio-core         ^>=0.2.0.1     , unordered-containers  ^>=0.2.10.0     , uri-bytestring        ^>=0.3.2.2-    , vector                ^>=0.12-    , versions              >=4.0.1      && <5.1+    , vector                 >=0.12     && <0.14+    , versions              >=6.0.3      && <6.1     , word8                 ^>=0.1.3     , yaml-streamly         ^>=0.12.0     , zlib                  ^>=0.6.2.2@@ -197,13 +236,13 @@       , unix             ^>=2.7       , unix-bytestring  ^>=0.3.7.3 -  if (flag(tui) && !os(windows))+  if flag(tui)     cpp-options:   -DBRICK-    build-depends: vty ^>=5.37+    build-depends: vty ^>=6.0 -executable ghcup-  main-is:            Main.hs-  other-modules:+library ghcup-optparse+  import:             app-common-depends+  exposed-modules:     GHCup.OptParse     GHCup.OptParse.ChangeLog     GHCup.OptParse.Common@@ -224,6 +263,40 @@     GHCup.OptParse.Upgrade     GHCup.OptParse.Whereis +  hs-source-dirs:     lib-opt+  default-language:   Haskell2010+  default-extensions:+    LambdaCase+    MultiWayIf+    NamedFieldPuns+    PackageImports+    RecordWildCards+    ScopedTypeVariables+    StrictData+    TupleSections++  ghc-options:+    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns+    -fwarn-incomplete-record-updates++  build-depends:      ghcup++  if flag(internal-downloader)+    cpp-options: -DINTERNAL_DOWNLOADER++  if flag(tui)+    cpp-options:   -DBRICK++  if os(windows)+    cpp-options: -DIS_WINDOWS++  else+    build-depends: unix ^>=2.7++executable ghcup+  import:             app-common-depends+  main-is:            Main.hs+   hs-source-dirs:     app/ghcup   default-language:   Haskell2010   default-extensions:@@ -241,53 +314,19 @@     -fwarn-incomplete-record-updates -threaded    build-depends:-    , aeson                  >=1.4-    , aeson-pretty           ^>=0.8.8-    , async                  ^>=2.2.3-    , base                   >=4.12     && <5-    , bytestring             >=0.10     && <0.12-    , cabal-install-parsers  >=0.4.5-    , cabal-plan             ^>=0.7.2-    , containers             ^>=0.6-    , deepseq                ^>=1.4-    , directory              ^>=1.3.6.0-    , filepath               ^>=1.4.2.1     , ghcup-    , haskus-utils-types     ^>=1.5-    , haskus-utils-variant   ^>=3.2.1-    , libarchive             ^>=3.0.3.0-    , megaparsec             >=8.0.0    && <9.3-    , mtl                    ^>=2.2-    , optparse-applicative   >=0.15.1.0 && <0.18-    , pretty                 ^>=1.1.3.1-    , pretty-terminal        ^>=0.1.0.0-    , process                ^>=1.6.11.0-    , resourcet              ^>=1.2.2-    , safe                   ^>=0.3.18-    , safe-exceptions        ^>=0.1-    , tagsoup                ^>=0.14-    , template-haskell       >=2.7      && <2.20-    , temporary              ^>=1.3-    , text                   ^>=2.0-    , time                   ^>=1.9.3 || ^>=1.10 || ^>=1.11-    , unordered-containers   ^>=0.2-    , uri-bytestring         ^>=0.3.2.2-    , utf8-string            ^>=1.0-    , vector                 ^>=0.12-    , versions               >=4.0.1    && <5.1-    , yaml-streamly          ^>=0.12.0+    , ghcup-optparse    if flag(internal-downloader)     cpp-options: -DINTERNAL_DOWNLOADER -  if (flag(tui) && !os(windows))+  if flag(tui)     cpp-options:   -DBRICK     other-modules: BrickMain     build-depends:-      , brick         ^>=1.5+      , brick         ^>=2.1       , transformers  ^>=0.5-      , unix          ^>=2.7-      , vty           ^>=5.37+      , vty           ^>=6.0    if os(windows)     cpp-options: -DIS_WINDOWS@@ -302,7 +341,7 @@   type:               exitcode-stdio-1.0   main-is:            Main.hs   build-tool-depends: hspec-discover:hspec-discover -any-  hs-source-dirs:     test+  hs-source-dirs:     test/ghcup-test   other-modules:     GHCup.ArbitraryTypes     GHCup.Prelude.File.Posix.TraversalsSpec@@ -336,13 +375,50 @@     , QuickCheck                ^>=2.14.1     , quickcheck-arbitrary-adt  ^>=0.3.1.0     , streamly                  ^>=0.8.2-    , time                      ^>=1.9.3 || ^>=1.10 || ^>=1.11     , text                      ^>=2.0+    , time                      >=1.9.3   && <1.12     , uri-bytestring            ^>=0.3.2.2-    , versions                  >=4.0.1   && <5.1+    , versions                  >=6.0.3   && <6.1    if os(windows)     cpp-options: -DIS_WINDOWS    else     build-depends: unix ^>=2.7++test-suite ghcup-optparse-test+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/optparse-test+  main-is:          Main.hs+  other-modules:+    ChangeLogTest+    CompileTest+    ConfigTest+    GCTest+    InstallTest+    ListTest+    OtherCommandTest+    RmTest+    RunTest+    SetTest+    UnsetTest+    UpgradeTest+    Utils+    WhereisTest++  if os(windows)+    cpp-options: -DIS_WINDOWS++  default-language: Haskell2010+  ghc-options:      -Wall+  build-depends:+    , base+    , ghcup+    , ghcup-optparse+    , optparse-applicative+    , tasty+    , tasty-hunit+    , template-haskell+    , text+    , uri-bytestring+    , versions

@@ -0,0 +1,360 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+++module GHCup.OptParse (+    module GHCup.OptParse.Common+  , module GHCup.OptParse.Install+  , module GHCup.OptParse.Test+  , 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+#ifndef DISABLE_UPGRADE+  , module GHCup.OptParse.Upgrade+#endif+  , 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.Run+  , module GHCup.OptParse+) where+++import           GHCup.OptParse.Common+import           GHCup.OptParse.Install+import           GHCup.OptParse.Test+import           GHCup.OptParse.Set+import           GHCup.OptParse.UnSet+import           GHCup.OptParse.Rm+import           GHCup.OptParse.Run+import           GHCup.OptParse.Compile+import           GHCup.OptParse.Config+import           GHCup.OptParse.Whereis+import           GHCup.OptParse.List+#ifndef DISABLE_UPGRADE+import           GHCup.OptParse.Upgrade+#endif+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.Either+import           Data.Functor+import           Data.Maybe+import           Options.Applicative     hiding ( style )+import           Options.Applicative.Help.Pretty ( text )+import           Prelude                 hiding ( appendFile )++++data Options = Options+  {+  -- global options+    optVerbose     :: Maybe Bool+  , optCache       :: Maybe Bool+  , optMetaCache   :: Maybe Integer+  , optMetaMode    :: Maybe MetaMode+  , optPlatform    :: Maybe PlatformRequest+  , optUrlSource   :: Maybe URLSource+  , optNoVerify    :: Maybe Bool+  , optKeepDirs    :: Maybe KeepDirs+  , optsDownloader :: Maybe Downloader+  , optNoNetwork   :: Maybe Bool+  , optGpg         :: Maybe GPGSetting+  , optStackSetup  :: Maybe Bool+  -- commands+  , optCommand     :: Command+  }++data Command+  = Install (Either InstallCommand InstallOptions)+  | Test TestCommand+  | InstallCabalLegacy InstallOptions+  | Set (Either SetCommand SetOptions)+  | UnSet UnsetCommand+  | List ListOptions+  | Rm (Either RmCommand RmOptions)+  | DInfo+  | Compile CompileCommand+  | Config ConfigCommand+  | Whereis WhereisOptions WhereisCommand+#ifndef DISABLE_UPGRADE+  | Upgrade UpgradeOpts Bool Bool+#endif+  | ToolRequirements ToolReqOpts+  | ChangeLog ChangeLogOptions+  | Nuke+#if defined(BRICK)+  | Interactive+#endif+  | Prefetch PrefetchCommand+  | GC GCOptions+  | Run RunOptions+  | PrintAppErrors++++opts :: Parser Options+opts =+  Options+    <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")+    <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")+    <*> optional (option auto (long "metadata-caching" <> metavar "SEC" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable"))+    <*> optional (option auto (long "metadata-fetching-mode" <> metavar "<Strict|Lax>" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))"))+    <*> 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 parseUrlSource)+            (  short 's'+            <> long "url-source"+            <> metavar "URL_SOURCE"+            <> help "Alternative ghcup download info"+            <> internal+            <> completer urlSourceCompleter+            )+          )+    <*> (fmap . fmap) not (invertableSwitch "verify" (Just '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+          <> completer (listCompleter ["always", "errors", "never"])+          ))+    <*> optional (option+          (eitherReader downloaderParser)+          (  long "downloader"+#if defined(INTERNAL_DOWNLOADER)+          <> metavar "<internal|curl|wget>"+          <> help+          "Downloader to use (default: internal)"+          <> completer (listCompleter ["internal", "curl", "wget"])+#else+          <> metavar "<curl|wget>"+          <> help+          "Downloader to use (default: curl)"+          <> completer (listCompleter ["curl", "wget"])+#endif+          <> hidden+          ))+    <*> invertableSwitch "offline" (Just '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)"+          <> completer (listCompleter ["strict", "lax", "none"])+          ))+    <*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions")+    <*> com++++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+           "test"+           (info+             (Test <$> testParser <**> helper)+             (  progDesc "Run tests for a tool (if any) [EXPERIMENTAL!]"+             <> footerDoc (Just $ text testFooter)+             )+           )+      <> 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"+                 <> footerDoc (Just $ text listToolFooter))+           )+      <> command+           "upgrade"+           (info+             (    (Upgrade <$> upgradeOptsP <*> switch+                    (short 'f' <> long "force" <> help "Force update")+                    <*> switch+                    (long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")+                  )+             <**> 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 ))+           )+      <> command+              "run"+               (Run+               <$>+                 info+                   (runOpts <**> helper)+                   (progDesc "Run a command with the given tool in PATH"+                   <> footerDoc ( Just $ text runFooter )+                   )+               )+      <> commandGroup "Main commands:"+      )+    <|> subparser+          (  command+              "debug-info"+              ((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))+          <> command+               "tool-requirements"+               (   ToolRequirements+               <$> info (toolReqP <**> 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+          )+     <|> subparser+          (command+              "print-app-errors"+               (info (pure PrintAppErrors <**> helper)+                     (progDesc ""))+           <> internal+          )

@@ -0,0 +1,148 @@+{-# 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.Errors+import           GHCup.OptParse.Common+import           GHCup.Prelude+import           GHCup.Prelude.Logger+import           GHCup.Prelude.String.QQ+import           GHCup.Prelude.Process (exec)++#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 URI.ByteString (serializeURIRef')+import Data.Char (toLower)++++    ---------------+    --[ Options ]--+    ---------------+++data ChangeLogOptions = ChangeLogOptions+  { clOpen    :: Bool+  , clTool    :: Maybe Tool+  , clToolVer :: Maybe ToolVersion+  } deriving (Eq, Show)+++++    ---------------+    --[ 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+                "hls"   -> Right HLS+                e       -> Left e+              )+            )+            (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup|stack>" <> help+              "Open changelog for given tool (default: ghc)"+              <> completer toolCompleter+            )+          )+    <*> optional (toolVersionTagArgument [] 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' = fromMaybe+        (ToolTag Latest)+        clToolVer+      muri = getChangeLog dls tool ver'+  case muri of+    Nothing -> do+      runLogger+        (logWarn $+          "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> T.pack (prettyShow 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 $ prettyHFError e)+                      >> pure (ExitFailure 13)+        else liftIO $ putStrLn uri' >> pure ExitSuccess

@@ -0,0 +1,844 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ViewPatterns      #-}++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.Prelude+import           GHCup.Prelude.Process+import           GHCup.Prelude.Logger+import           GHCup.Prelude.MegaParsec++import           Control.DeepSeq+import           Control.Concurrent+import           Control.Concurrent.Async+import           Control.Exception.Safe+import           Control.Monad.Identity (Identity(..))+#if !MIN_VERSION_base(4,13,0)+import           Control.Monad.Fail             ( MonadFail )+#endif+import           Control.Monad.Reader+import           Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key    as KM+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif+import           Data.ByteString.Lazy           ( ByteString )+import           Data.Bifunctor+import           Data.Char+import           Data.Either+import           Data.Functor+import           Data.List                      ( nub, sort, sortBy, isPrefixOf, stripPrefix )+import           Data.Maybe+import           Data.Text                      ( Text )+import           Data.Time.Calendar             ( Day )+import           Data.Time.Format               ( parseTimeM, defaultTimeLocale )+import           Data.Versions+import           Data.Void+import qualified Data.Vector      as V+import           GHC.IO.Exception+import           Haskus.Utils.Variant.Excepts+import           Options.Applicative     hiding ( style )+import           Prelude                 hiding ( appendFile )+import           Safe+import           System.Process                  ( readProcess )+import           System.FilePath+import           Text.HTML.TagSoup       hiding ( Tag )+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 Data.Text.Lazy.Encoding       as LE+import qualified Data.Text.Lazy                as LT+import qualified Text.Megaparsec               as MP+import qualified System.FilePath.Posix         as FP+import GHCup.Version+import Control.Exception (evaluate)+import qualified Cabal.Config            as CC+++    -------------+    --[ Types ]--+    -------------+++-- a superset of ToolVersion+data SetToolVersion = SetGHCVersion GHCTargetVersion+                    | SetToolVersion Version+                    | SetToolTag Tag+                    | SetToolDay Day+                    | SetRecommended+                    | SetNext+                    deriving (Eq, Show)++prettyToolVer :: ToolVersion -> String+prettyToolVer (GHCVersion v')  = T.unpack $ tVerToText v'+prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v'+prettyToolVer (ToolTag t)      = show t+prettyToolVer (ToolDay day)    = show day++toSetToolVer :: Maybe ToolVersion -> SetToolVersion+toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v'+toSetToolVer (Just (ToolVersion v')) = SetToolVersion v'+toSetToolVer (Just (ToolTag t')) = SetToolTag t'+toSetToolVer (Just (ToolDay d')) = SetToolDay d'+toSetToolVer Nothing = SetRecommended+++++    --------------+    --[ Parser ]--+    --------------+++toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion+toolVersionTagArgument criteria tool =+  argument (eitherReader (parser tool))+    (metavar (mv tool)+    <> completer (tagCompleter (fromMaybe GHC tool) [])+    <> foldMap (completer . versionCompleter criteria) tool)+ where+  mv (Just GHC) = "GHC_VERSION|TAG|RELEASE_DATE"+  mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE"+  mv _          = "VERSION|TAG|RELEASE_DATE"++  parser (Just GHC) = ghcVersionTagEither+  parser Nothing    = ghcVersionTagEither+  parser _          = toolVersionTagEither+++versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version+versionParser' criteria tool = argument+  (eitherReader (first show . version . T.pack))+  (metavar "VERSION"  <> foldMap (completer . versionCompleter criteria) tool)++ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion+ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)+                                            (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+    -> Maybe 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")+    -> Maybe 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 maybe mempty short shortopt)+    <|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty 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' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros)+++uriParser :: String -> Either String URI+uriParser = 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 && isAbsolute f of+              True -> Right $ normalise f+              False -> Left "Please enter a valid filepath for isolate dir."++-- this accepts cross prefix+ghcVersionTagEither :: String -> Either String ToolVersion+ghcVersionTagEither s' =+  second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s')++-- this ignores cross prefix+toolVersionTagEither :: String -> Either String ToolVersion+toolVersionTagEither s' =+  second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')++tagEither :: String -> Either String Tag+tagEither s' = case fmap toLower s' of+  "recommended"              -> Right Recommended+  "latest"                   -> Right Latest+  "latest-prerelease"        -> Right LatestPrerelease+  "latest-nightly"           -> Right LatestNightly+  ('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+++ghcVersionEither :: String -> Either String GHCTargetVersion+ghcVersionEither =+  first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack++toolVersionEither :: String -> Either String Version+toolVersionEither =+  first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . 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')++dayParser :: String -> Either String Day+dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right+            $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s+++criteriaParser :: String -> Either String ListCriteria+criteriaParser s' | t == T.pack "installed"   = Right $ ListInstalled True+                  | t == T.pack "set"         = Right $ ListSet True+                  | t == T.pack "available"   = Right $ ListAvailable True+                  | t == T.pack "+installed"  = Right $ ListInstalled True+                  | t == T.pack "+set"        = Right $ ListSet True+                  | t == T.pack "+available"  = Right $ ListAvailable True+                  | t == T.pack "-installed"  = Right $ ListInstalled False+                  | t == T.pack "-set"        = Right $ ListSet False+                  | t == T.pack "-available"  = Right $ ListAvailable False+                  | 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')++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 ]--+    ------------------+++toolCompleter :: Completer+toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]++gitFileUri :: [String] -> Completer+gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)++urlSourceCompleter :: Completer+urlSourceCompleter = mkCompleter $ urlSourceCompleter' []++urlSourceCompleter' :: [String] -> String -> IO [String]+urlSourceCompleter' add str' = do+  let static = ["GHCupURL", "StackSetupURL"]+  file <- fileUri' add str'+  pure $ static ++ file++fileUri :: Completer+fileUri = mkCompleter $ fileUri' []++fileUri' :: [String] -> String -> IO [String]+fileUri' add = \case+  "" -> do+    pwd <- getCurrentDirectory+    pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add+  xs+   | "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>+      case stripPrefix "file://" xs of+        Nothing -> pure []+        Just r ->  do+          pwd <- getCurrentDirectory+          dirs  <- compgen "directory" r ["-S", "/"]+          files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []+          pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])+   | xs `isPrefixOf` "file:///" -> pure ["file:///"]+   | xs `isPrefixOf` "https://" -> pure ["https://"]+   | xs `isPrefixOf` "http://"  -> pure ["http://"]+   | otherwise -> pure []+ where+  compgen :: String -> String -> [String] -> IO [String]+  compgen action' r opts = do+    let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]+    result <- tryIO $ readProcess "bash" ["-c", cmd] ""+    return . lines . either (const []) id $ result++  -- | Strongly quote the string we pass to compgen.+  --+  -- We need to do this so bash doesn't expand out any ~ or other+  -- chars we want to complete on, or emit an end of line error+  -- when seeking the close to the quote.+  --+  -- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote+  requote :: String -> String+  requote s =+    let+      -- Bash doesn't appear to allow "mixed" escaping+      -- in bash completions. So we don't have to really+      -- worry about people swapping between strong and+      -- weak quotes.+      unescaped =+        case s of+          -- It's already strongly quoted, so we+          -- can use it mostly as is, but we must+          -- ensure it's closed off at the end and+          -- there's no single quotes in the+          -- middle which might confuse bash.+          ('\'': rs) -> unescapeN rs++          -- We're weakly quoted.+          ('"': rs)  -> unescapeD rs++          -- We're not quoted at all.+          -- We need to unescape some characters like+          -- spaces and quotation marks.+          elsewise   -> unescapeU elsewise+    in+      strong unescaped++    where+      strong ss = '\'' : foldr go "'" ss+        where+          -- If there's a single quote inside the+          -- command: exit from the strong quote and+          -- emit it the quote escaped, then resume.+          go '\'' t = "'\\''" ++ t+          go h t    = h : t++      -- Unescape a strongly quoted string+      -- We have two recursive functions, as we+      -- can enter and exit the strong escaping.+      unescapeN = goX+        where+          goX ('\'' : xs) = goN xs+          goX (x : xs) = x : goX xs+          goX [] = []++          goN ('\\' : '\'' : xs) = '\'' : goN xs+          goN ('\'' : xs) = goX xs+          goN (x : xs) = x : goN xs+          goN [] = []++      -- Unescape an unquoted string+      unescapeU = goX+        where+          goX [] = []+          goX ('\\' : x : xs) = x : goX xs+          goX (x : xs) = x : goX xs++      -- Unescape a weakly quoted string+      unescapeD = goX+        where+          -- Reached an escape character+          goX ('\\' : x : xs)+            -- If it's true escapable, strip the+            -- slashes, as we're going to strong+            -- escape instead.+            | x `elem` ("$`\"\\\n" :: String) = x : goX xs+            | otherwise = '\\' : x : goX xs+          -- We've ended quoted section, so we+          -- don't recurse on goX, it's done.+          goX ('"' : xs)+            = xs+          -- Not done, but not a special character+          -- just continue the fold.+          goX (x : xs)+            = x : goX xs+          goX []+            = []+++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+        (defaultSettings { noNetwork = True })+        dirs'+        defaultKeyBindings+        loggerConfig++  mpFreq <- flip runReaderT appState . runE $ platformRequest+  forFold mpFreq $ \pfreq -> do+    mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq+    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", "latest-prerelease"] ++ add)++versionCompleter :: [ListCriteria] -> Tool -> Completer+versionCompleter criteria tool = versionCompleter' criteria tool (const True)++versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer+versionCompleter' criteria tool filter' = listIOCompleter $ do+  dirs' <- liftIO getAllDirs+  let loggerConfig = LoggerConfig+        { lcPrintDebug   = False+        , consoleOutter  = mempty+        , fileOutter     = mempty+        , fancyColors    = False+        }+  let settings = defaultSettings { noNetwork = True }+  let leanAppState = LeanAppState+                   settings+                   dirs'+                   defaultKeyBindings+                   loggerConfig+  mpFreq <- flip runReaderT leanAppState . runE $ platformRequest+  forFold mpFreq $ \pfreq -> do+    mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq+    forFold mGhcUpInfo $ \ghcupInfo -> do+      let appState = AppState+            settings+            dirs'+            defaultKeyBindings+            ghcupInfo+            pfreq+            loggerConfig++          runEnv = flip runReaderT appState++      installedVersions <- runEnv $ listVersions (Just tool) criteria False False (Nothing, Nothing)+      return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions+++toolDlCompleter :: Tool -> Completer+toolDlCompleter tool = mkCompleter $ \case+  "" -> pure (initUrl tool <> ["https://", "http://", "file:///"])+  word+    | "file://" `isPrefixOf` word -> fileUri' [] word+    -- downloads.haskell.org+    | "https://downloads.haskell.org/" `isPrefixOf` word ->+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word++    -- github releases+    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word+    , let xs = splitPath word+    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->+        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"+    | "https://github.com/commercialhaskell/stack/releases/download/" == word+    , let xs = splitPath word+    , (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->+        fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"++    -- github release assets+    | "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word+    , let xs = splitPath word+    , (length xs == 7 && last word == '/') || length xs == 8+    , let rel = xs !! 6+    , length rel > 1 -> do+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)+    | "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word+    , let xs = splitPath word+    , (length xs == 7 && last word == '/') || length xs == 8+    , let rel = xs !! 6+    , length rel > 1 -> do+        fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)++    -- github+    | "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]+    | "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]+    | "https://g" `isPrefixOf` word+    , tool == Stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]+    | "https://g" `isPrefixOf` word+    , tool == HLS -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]++    | "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool++    | "h" `isPrefixOf` word -> pure $ initUrl tool++    | word `isPrefixOf` "file:///" -> pure ["file:///"]+    | word `isPrefixOf` "https://" -> pure ["https://"]+    | word `isPrefixOf` "http://"  -> pure ["http://"]++    | otherwise -> pure []+ where+  initUrl :: Tool -> [String]+  initUrl GHC   = [ "https://downloads.haskell.org/~ghc/"+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"+                  ]+  initUrl Cabal = [ "https://downloads.haskell.org/~cabal/"+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"+                  ]+  initUrl GHCup = [ "https://downloads.haskell.org/~ghcup/" ]+  initUrl HLS   = [ "https://github.com/haskell/haskell-language-server/releases/download/"+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"+                  ]+  initUrl Stack = [ "https://github.com/commercialhaskell/stack/releases/download/"+                  , "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"+                  ]++  completePrefix :: String -- ^ url, e.g.    'https://github.com/haskell/haskell-languag'+                 -> String -- ^ match, e.g.  'haskell-language-server'+                 -> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'+  completePrefix url match =+    let base = FP.takeDirectory url+        fn   = FP.takeFileName url+    in if fn `isPrefixOf` match then base <> "/" <> match else url++  prefixMatch :: String -> [String] -> [String]+  prefixMatch pref = filter (pref `isPrefixOf`)++  fromHRef :: String -> IO [String]+  fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->+      pure+        . fmap (T.unpack . decUTF8Safe' . fromAttrib "href")+        . filter isTagOpen+        . filter (~== ("<a href>" :: String))+        . parseTags+        $ stdout++  withCurl :: String                      -- ^ url+           -> Int                         -- ^ delay+           -> (ByteString -> IO [String]) -- ^ callback+           -> IO [String]+  withCurl url delay cb = do+    let limit = threadDelay delay+    race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case+      Right (CapturedProcess {_exitCode, _stdOut}) -> do+        case _exitCode of+          ExitSuccess ->+            (try @_ @SomeException . cb $ _stdOut) >>= \case+              Left _ ->  pure []+              Right r' -> do+                r <- try @_ @SomeException+                  . evaluate+                  . force+                  $ r'+                either (\_ -> pure []) pure r+          ExitFailure _ -> pure []+      Left _ -> pure []++  getGithubReleases :: String+                    -> String+                    -> IO [String]+  getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do+    Just xs <- pure $ decode' @Array stdout+    fmap V.toList $ forM xs $ \x -> do+      (Object r) <- pure x+      Just (String name) <- pure $ KM.lookup (mkval "tag_name") r+      pure $ T.unpack name+   where+    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"++  getGithubAssets :: String+                  -> String+                  -> String+                  -> IO [String]+  getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do+    Just xs <- pure $ decode' @Object stdout+    Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs+    as <- fmap V.toList $ forM assets $ \val -> do+      (Object asset) <- pure val+      Just (String name) <- pure $ KM.lookup (mkval "name") asset+      pure $ T.unpack name+    pure as+   where+    url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag+++#if MIN_VERSION_aeson(2,0,0)+  mkval = KM.fromString+#else+  mkval = id+#endif+++++++    -----------------+    --[ Utilities ]--+    -----------------+++fromVersion :: ( HasLog env+               , MonadFail m+               , MonadReader env m+               , HasGHCupInfo env+               , HasDirs env+               , MonadThrow m+               , MonadIO m+               , MonadCatch m+               )+            => Maybe ToolVersion+            -> Tool+            -> Excepts+                 '[ TagNotFound+                  , DayNotFound+                  , 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+                   , DayNotFound+                   , NextVerNotFound+                   , NoToolVersionSet+                   ] m (GHCTargetVersion, Maybe VersionInfo)+fromVersion' SetRecommended tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  second Just <$> getRecommended dls tool+    ?? TagNotFound Recommended tool+fromVersion' (SetGHCVersion v) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  let vi = getVersionInfo v tool dls+  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here+    Left _ -> pure (v, vi)+    Right pvpIn ->+      lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case+        Just (pvp_, vi', mt) -> do+          v' <- lift $ pvpToVersion pvp_ ""+          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')+          pure (GHCTargetVersion mt v', Just vi')+        Nothing -> pure (v, vi)+fromVersion' (SetToolVersion (mkTVer -> v)) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  let vi = getVersionInfo v tool dls+  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here+    Left _ -> pure (v, vi)+    Right pvpIn ->+      lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case+        Just (pvp_, vi', mt) -> do+          v' <- lift $ pvpToVersion pvp_ ""+          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')+          pure (GHCTargetVersion mt v', Just vi')+        Nothing -> pure (v, vi)+fromVersion' (SetToolTag Latest) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool+fromVersion' (SetToolDay day) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id Just <$> case getByReleaseDay dls tool day of+                          Left ad -> throwE $ DayNotFound day tool ad+                          Right v -> pure v+fromVersion' (SetToolTag LatestPrerelease) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool+fromVersion' (SetToolTag LatestNightly) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool+fromVersion' (SetToolTag Recommended) tool = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool+fromVersion' (SetToolTag (Base pvp'')) GHC = do+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+  bimap id 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 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 [(Tool, GHCTargetVersion)]+checkForUpdates = do+  GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo+  lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)+  let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled++  ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do+    (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer+    if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing++  otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->+    forMM (getLatest dls t) $ \(l, _) -> do+      let mver = latestInstalled t+      forMM mver $ \ver ->+        if (l > ver) then pure $ Just (t, l) else pure Nothing++  pure $ catMaybes (ghcup:otherTools)+ where+  forMM a f = fmap join $ forM a f+++logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m ()+logGHCPostRm ghcVer = do+  cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store")+    (runIdentity . CC.cfgStoreDir <$> CC.readConfig)+  let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))+  logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir++parseUrlSource :: String -> Either String URLSource+parseUrlSource "GHCupURL" = pure GHCupURL+parseUrlSource "StackSetupURL" = pure StackSetupURL+parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')+            <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')++parseNewUrlSource :: String -> Either String NewURLSource+parseNewUrlSource "GHCupURL" = pure NewGHCupURL+parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL+parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')+            <|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')+