Implement ghcup gc command

Fixes #241

.gitlab-ci.yml

@@ -86,7 +86,7 @@ variables:
 
 .freebsd12:
   tags:
-    - x86_64-freebsd
+    - x86_64-freebsd12
   variables:
     OS: "FREEBSD"
     ARCH: "64"
@@ -109,7 +109,7 @@ variables:
   script:
     - bash ./.gitlab/script/ghcup_version.sh
   variables:
-    JSON_VERSION: "0.0.7"
+    JSON_VERSION: "0.0.6"
   artifacts:
     expire_in: 2 week
     paths:
@@ -225,7 +225,7 @@ variables:
   only:
     - tags
   variables:
-    JSON_VERSION: "0.0.7"
+    JSON_VERSION: "0.0.6"
 
 ######## stack test ########
 

app/ghcup-gen/Main.hs

@@ -11,21 +11,23 @@
 module Main where
 
 import           GHCup.Types
-import           GHCup.Types.Optics
 import           GHCup.Errors
 import           GHCup.Platform
 import           GHCup.Utils.Dirs
+import           GHCup.Utils.Logger
 import           GHCup.Types.JSON               ( )
 
 import           Control.Monad.Trans.Reader     ( runReaderT )
 import           Control.Monad.IO.Class
 import           Data.Char                      ( toLower )
+import           Data.Maybe
 #if !MIN_VERSION_base(4,13,0)
 import           Data.Semigroup                 ( (<>) )
 #endif
 import           Options.Applicative     hiding ( style )
 import           Haskus.Utils.Variant.Excepts
 import           System.Console.Pretty
+import           System.Environment
 import           System.Exit
 import           System.IO                      ( stderr )
 import           Text.Regex.Posix
@@ -114,12 +116,14 @@ com = subparser
 
 main :: IO ()
 main = do
-  let loggerConfig = LoggerConfig { lcPrintDebug = True
-                                  , colorOutter  = T.hPutStr stderr
-                                  , rawOutter    = \_ -> pure ()
+  no_color <- isJust <$> lookupEnv "NO_COLOR"
+  let loggerConfig = LoggerConfig { lcPrintDebug  = True
+                                  , consoleOutter = T.hPutStr stderr
+                                  , fileOutter    = \_ -> pure ()
+                                  , fancyColors   = not no_color
                                   }
   dirs <- liftIO getAllDirs
-  let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings loggerConfig
+  let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig
 
   pfreq <- (
     flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
@@ -129,7 +133,7 @@ main = do
               flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
               liftIO $ exitWith (ExitFailure 2)
 
-  let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
+  let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
 
   _ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
     >>= \Options {..} -> case optCommand of

app/ghcup-gen/Validate.hs

@@ -15,6 +15,7 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Version.QQ
 
 import           Codec.Archive

app/ghcup/BrickMain.hs

@@ -13,9 +13,9 @@ module BrickMain where
 import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
-import           GHCup.Types.Optics  hiding ( getGHCupInfo )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude ( decUTF8Safe )
 import           GHCup.Utils.File
 
@@ -43,7 +43,6 @@ import           Data.Vector                    ( Vector
 import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( appendFile )
-import           System.Environment
 import           System.Exit
 import           System.IO.Unsafe
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -537,9 +536,10 @@ settings' :: IORef AppState
 {-# NOINLINE settings' #-}
 settings' = unsafePerformIO $ do
   dirs <- getAllDirs
-  let loggerConfig = LoggerConfig { lcPrintDebug = False
-                                  , colorOutter  = \_ -> pure ()
-                                  , rawOutter    = \_ -> pure ()
+  let loggerConfig = LoggerConfig { lcPrintDebug  = False
+                                  , consoleOutter = \_ -> pure ()
+                                  , fileOutter    = \_ -> pure ()
+                                  , fancyColors   = True
                                   }
   newIORef $ AppState (Settings { cache      = True
                                 , noVerify   = False
@@ -549,6 +549,7 @@ settings' = unsafePerformIO $ do
                                 , urlSource  = GHCupURL
                                 , noNetwork  = False
                                 , gpgSetting = GPGNone
+                                , noColor    = False
                                 , ..
                                 })
                       dirs
@@ -564,13 +565,11 @@ brickMain :: AppState
 brickMain s = do
   writeIORef settings' s
 
-  no_color <- isJust <$> lookupEnv "NO_COLOR"
-
   eAppData <- getAppData (Just $ ghcupInfo s)
   case eAppData of
     Right ad ->
       defaultMain
-          (app (defaultAttributes no_color) (dimAttributes no_color))
+          (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
           (BrickState ad
                     defaultAppSettings
                     (constructList ad defaultAppSettings Nothing)

app/ghcup/Main.hs

@@ -49,7 +49,6 @@ import           Data.Char
 import           Data.Either
 import           Data.Functor
 import           Data.List                      ( intercalate, nub, sort, sortBy )
-import           Data.List.NonEmpty             (NonEmpty ((:|)))
 import           Data.Maybe
 import           Data.Text                      ( Text )
 import           Data.Versions           hiding ( str )
@@ -118,6 +117,7 @@ data Command
   | Interactive
 #endif
   | Prefetch PrefetchCommand
+  | GC GCOptions
 
 data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
                  | ToolTag Tag
@@ -146,6 +146,15 @@ data InstallOptions = InstallOptions
   , forceInstall :: Bool
   }
 
+data GCOptions = GCOptions
+  { gcOldGHC :: Bool
+  , gcProfilingLibs :: Bool
+  , gcShareDir :: Bool
+  , gcHLSNoGHC :: Bool
+  , gcCache :: Bool
+  , gcTmp :: Bool
+  }
+
 data SetCommand = SetGHC SetOptions
                 | SetCabal SetOptions
                 | SetHLS SetOptions
@@ -213,6 +222,8 @@ data HLSCompileOptions = HLSCompileOptions
   , ovewrwiteVer :: Maybe Version
   , isolateDir   :: Maybe FilePath
   , cabalProject :: Maybe FilePath
+  , cabalProjectLocal :: Maybe FilePath
+  , patchDir     :: Maybe FilePath
   , targetGHCs   :: [ToolVersion]
   }
 
@@ -437,6 +448,16 @@ com =
              (progDesc "Prefetch assets"
              <> footerDoc ( Just $ text prefetchFooter ))
            )
+      <> command
+           "gc"
+            (info
+             (   (GC
+                     <$> gcP
+                 ) <**> helper
+             )
+             (progDesc "Garbage collection"
+             <> footerDoc ( Just $ text gcFooter ))
+           )
       <> commandGroup "Main commands:"
       )
     <|> subparser
@@ -541,6 +562,10 @@ Examples:
   ghcup prefetch ghc 8.10.5
   ghcup --offline install ghc 8.10.5|]
 
+  gcFooter :: String
+  gcFooter = [s|Discussion:
+  Performs garbage collection. If no switches are specified, does nothing.|]
+
 configFooter :: String
 configFooter = [s|Examples:
 
@@ -822,7 +847,7 @@ listOpts =
     <$> optional
           (option
             (eitherReader toolParser)
-            (short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
+            (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|stack>" <> help
               "Tool to list versions for. Default is all"
             )
           )
@@ -831,8 +856,8 @@ listOpts =
             (eitherReader criteriaParser)
             (  short 'c'
             <> long "show-criteria"
-            <> metavar "<installed|set>"
-            <> help "Show only installed or set tool versions"
+            <> metavar "<installed|set|available>"
+            <> help "Show only installed/set/available tool versions"
             )
           )
     <*> switch
@@ -941,6 +966,8 @@ Examples:
 
   compileHLSFooter = [s|Discussion:
   Compiles and installs the specified HLS version.
+  The last argument is a list of GHC versions to compile for.
+  These need to be available in PATH prior to compilation.
 
 Examples:
   ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|]
@@ -1119,6 +1146,28 @@ prefetchP = subparser
       )
   )
 
+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")
+
 
 ghcCompileOpts :: Parser GHCCompileOptions
 ghcCompileOpts =
@@ -1266,11 +1315,25 @@ hlsCompileOpts =
     <*> optional
           (option
             str
-            (short 'p' <> long "projectfile" <> metavar "CABAL_PROJECT_LOCAL" <> help
-              "Absolute path to a cabal.project.local to be used for the build"
+            (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
+              "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
             )
           )
-    <*> many (toolVersionArgument Nothing (Just GHC))
+    <*> optional
+          (option
+            (eitherReader absolutePathParser)
+            (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
+              "Absolute path to a cabal.project.local to be used for the build. Will be copied over."
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader absolutePathParser)
+            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+            )
+          )
+    <*> some (toolVersionArgument Nothing (Just GHC))
 
 
 toolVersionParser :: Parser ToolVersion
@@ -1287,9 +1350,13 @@ toolVersionParser = verP' <|> toolP
 toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
 toolVersionArgument criteria tool =
   argument (eitherReader toolVersionEither)
-    (metavar "VERSION|TAG"
+    (metavar (mv tool)
     <> completer (tagCompleter (fromMaybe GHC tool) [])
     <> foldMap (completer . versionCompleter criteria) tool)
+ where
+  mv (Just GHC) = "GHC_VERSION|TAG"
+  mv (Just HLS) = "HLS_VERSION|TAG"
+  mv _          = "VERSION|TAG"
 
 
 setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
@@ -1316,12 +1383,13 @@ tagCompleter :: Tool -> [String] -> Completer
 tagCompleter tool add = listIOCompleter $ do
   dirs' <- liftIO getAllDirs
   let loggerConfig = LoggerConfig
-        { lcPrintDebug = False
-        , colorOutter  = mempty
-        , rawOutter    = mempty
+        { lcPrintDebug   = False
+        , consoleOutter  = mempty
+        , fileOutter     = mempty
+        , fancyColors    = False
         }
   let appState = LeanAppState
-        (Settings True False Never Curl False GHCupURL True GPGNone)
+        (Settings True False Never Curl False GHCupURL True GPGNone False)
         dirs'
         defaultKeyBindings
         loggerConfig
@@ -1342,11 +1410,12 @@ versionCompleter :: Maybe ListCriteria -> Tool -> Completer
 versionCompleter criteria tool = listIOCompleter $ do
   dirs' <- liftIO getAllDirs
   let loggerConfig = LoggerConfig
-        { lcPrintDebug = False
-        , colorOutter  = mempty
-        , rawOutter    = mempty
+        { lcPrintDebug   = False
+        , consoleOutter  = mempty
+        , fileOutter     = mempty
+        , fancyColors    = False
         }
-  let settings = Settings True False Never Curl False GHCupURL True GPGNone
+  let settings = Settings True False Never Curl False GHCupURL True GPGNone False
   let leanAppState = LeanAppState
                    settings
                    dirs'
@@ -1405,6 +1474,8 @@ toolVersionEither s' =
 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')
 
@@ -1412,6 +1483,7 @@ toolParser s' | t == T.pack "ghc"   = Right GHC
 criteriaParser :: String -> Either String ListCriteria
 criteriaParser s' | t == T.pack "installed" = Right ListInstalled
                   | t == T.pack "set"       = Right ListSet
+                  | t == T.pack "available" = Right ListAvailable
                   | otherwise               = Left ("Unknown criteria: " <> s')
   where t = T.toLower (T.pack s')
 
@@ -1498,8 +1570,14 @@ isolateParser f = case isValid f of
               True -> Right $ normalise f
               False -> Left "Please enter a valid filepath for isolate dir."
 
+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."
+
 toSettings :: Options -> IO (Settings, KeyBindings)
 toSettings options = do
+  noColor <- isJust <$> lookupEnv "NO_COLOR"
   userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
     VRight r -> pure r
     VLeft (V (JSONDecodeError e)) -> do
@@ -1507,10 +1585,10 @@ toSettings options = do
       pure defaultUserSettings
     _ -> do
       die "Unexpected error!"
-  pure $ mergeConf options userConf
+  pure $ mergeConf options userConf noColor
  where
-   mergeConf :: Options -> UserSettings -> (Settings, KeyBindings)
-   mergeConf Options{..} UserSettings{..} =
+   mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
+   mergeConf Options{..} UserSettings{..} noColor =
      let cache       = fromMaybe (fromMaybe False uCache) optCache
          noVerify    = fromMaybe (fromMaybe False uNoVerify) optNoVerify
          verbose     = fromMaybe (fromMaybe False uVerbose) optVerbose
@@ -1556,7 +1634,7 @@ updateSettings config settings = do
          urlSource'  = fromMaybe urlSource uUrlSource
          noNetwork'  = fromMaybe noNetwork uNoNetwork
          gpgSetting' = fromMaybe gpgSetting uGPGSetting
-     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting'
+     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
 
 upgradeOptsP :: Parser UpgradeOpts
 upgradeOptsP =
@@ -1581,7 +1659,7 @@ describe_result = $( LitE . StringL <$>
                      runIO (do
                              CapturedProcess{..} <-  do
                               dirs <- liftIO getAllDirs
-                              let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone)
+                              let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)
                                                dirs
                                                defaultKeyBindings
                               flip runReaderT settings $ executeOut "git" ["describe"] Nothing
@@ -1661,17 +1739,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
           -- logger interpreter
           logfile <- flip runReaderT dirs initGHCupFileLogging
+          no_color <- isJust <$> lookupEnv "NO_COLOR"
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
-                , colorOutter  = T.hPutStr stderr
-                , rawOutter    =
+                , consoleOutter  = T.hPutStr stderr
+                , fileOutter    =
                     case optCommand of
                       Nuke -> \_ -> pure ()
                       _ -> T.appendFile logfile
+                , fancyColors = not no_color
                 }
           let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
           let runLogger = flip runReaderT leanAppstate
-          let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
+          let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { consoleOutter = \_ -> pure () } } :: LeanAppState)
 
 
           -------------------------
@@ -1945,6 +2025,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , FileDoesNotExistError
                       ]
 
+          let runGC =
+                  runAppState
+                  . runResourceT
+                  . runE
+                    @'[ NotInstalled
+                      ]
+
 
           -----------------------
           -- Command functions --
@@ -2309,7 +2396,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             List ListOptions {..} ->
               runListGHC (do
                   l <- listVersions loTool lCriteria
-                  liftIO $ printListResult lRawFormat l
+                  liftIO $ printListResult no_color lRawFormat l
                   pure ExitSuccess
                 )
 
@@ -2351,6 +2438,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             ovewrwiteVer
                             isolateDir
                             cabalProject
+                            cabalProjectLocal
+                            patchDir
                 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                 let vi = getVersionInfo targetVer HLS dls
                 when setCompile $ void $ liftE $
@@ -2662,6 +2751,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             VLeft e -> do
                               runLogger $ logError $ T.pack $ prettyShow e
                               pure $ ExitFailure 15
+            GC GCOptions{..} ->
+              runGC (do
+                  when gcOldGHC rmOldGHC
+                  lift $ when gcProfilingLibs rmProfilingLibs
+                  lift $ when gcShareDir rmShareDir
+                  lift $ when gcHLSNoGHC rmHLSNoGHC
+                  lift $ when gcCache rmCache
+                  lift $ when gcTmp rmTmp
+                   ) >>= \case
+                            VRight _ -> do
+                                  pure ExitSuccess
+                            VLeft e -> do
+                              runLogger $ logError $ T.pack $ prettyShow e
+                              pure $ ExitFailure 27
 
 
           case res of
@@ -2712,13 +2815,15 @@ fromVersion' SetRecommended tool = do
 fromVersion' (SetToolVersion v) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   let vi = getVersionInfo (_tvVersion v) tool dls
-  case pvp $ prettyVer (_tvVersion v) of
+  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
     Left _ -> pure (v, vi)
-    Right (PVP (major' :|[minor'])) ->
-      case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
-        Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
+    Right pvpIn ->
+      lift (getLatestToolFor tool pvpIn dls) >>= \case
+        Just (pvp_, vi') -> do
+          v' <- lift $ pvpToVersion pvp_
+          when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
+          pure (GHCTargetVersion (_tvTarget v) v', Just vi')
         Nothing -> pure (v, vi)
-    Right _ -> pure (v, vi)
 fromVersion' (SetToolTag Latest) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
@@ -2778,9 +2883,8 @@ fromVersion' (SetToolTag t') tool =
   throwE $ TagNotFound t' tool
 
 
-printListResult :: Bool -> [ListResult] -> IO ()
-printListResult raw lr = do
-  no_color <- isJust <$> lookupEnv "NO_COLOR"
+printListResult :: Bool -> Bool -> [ListResult] -> IO ()
+printListResult no_color raw lr = do
 
   let
     color | raw || no_color = flip const

cabal.project

@@ -8,11 +8,6 @@ package ghcup
     tests: True
     flags: +tui
 
-source-repository-package
-    type: git
-    location: https://github.com/bgamari/terminal-size
-    tag: 34ea816bd63f75f800eedac12c6908c6f3736036
-
 source-repository-package
     type: git
     location: https://github.com/hasufell/libarchive

data/metadata/ghcup-0.0.6.yaml

@@ -2269,7 +2269,7 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.6.0.0/cabal-install-3.6.0.0-armv7-linux.tar.xz
               dlHash: 11b5ca042a8bf45971224f2127a3e9d6b803f09210042ca80a254bea06f01a2e
   GHCup:
-    0.1.16.2:
+    0.1.17:
       viTags:
       - Recommended
       - Latest
@@ -2279,43 +2279,43 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-linux-ghcup-0.1.16.2
-              dlHash: d5e43b95ce1d42263376e414f7eb7c5dd440271c7c6cd9bad446fdeff3823893
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-linux-ghcup-0.1.17
+              dlHash: 1eaa33af4180f97edf02822d6d711ce618d9828fe9ebbf042d198fe6c1c9d153
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-apple-darwin-ghcup-0.1.16.2
-              dlHash: a334620ccce7705211b2142882dde544003e6030af4b91a44c890542a90f879f
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-apple-darwin-ghcup-0.1.17
+              dlHash: a3d4ed12f8631c0537d8d9531cc5518bc6f90edcee3326e5d4e0efb72c8dfc6f
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-portbld-freebsd-ghcup-0.1.16.2
-              dlHash: 92359592a5694375e53b22628920086bf4bbf0faff5be018a0ed3e745a6426a9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-portbld-freebsd-ghcup-0.1.17
+              dlHash: 83012de837773f3aa26182c607c2da85ee6ff3b0092becb78907700f407a27fb
           Windows:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/x86_64-mingw64-ghcup-0.1.16.2.exe
-              dlHash: ec78872a84213968c490675127b9aad2285980b747c68207801ae824b98c7948
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/x86_64-mingw64-ghcup-0.1.17.exe
+              dlHash: 40bda6050c800fa69af51d2e668426ca73b4179214bfeef329b795484991d258
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/i386-linux-ghcup-0.1.16.2
-              dlHash: 01968ca6decac7b6e8ba6e2c817870d3fa47289a6507e0c1ab563f7b6eec0e38
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/i386-linux-ghcup-0.1.17
+              dlHash: d0f887b13a2c7a11477dc54cb90b446ef0ebe1d2a6bfbf60ccd4b37fc5de70cc
           Linux_Alpine:
             unknown_versioning: *ghcup-32
         A_ARM64:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/aarch64-linux-ghcup-0.1.16.2
-              dlHash: 0bdbfc724e0ddabb266156eea83c2c4e19c6ed79dd06db0c29b7d69df8d9fa8c
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/aarch64-linux-ghcup-0.1.17
+              dlHash: be67cf8800ae305c5ba210b645f4fce8751763f3eac3db399f6efca145b7ab38
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/aarch64-apple-darwin-ghcup-0.1.16.2
-              dlHash: 8854e991a2ba1350abda59dab96ce50ae7729d1ce99399d67929ef31e90f1da5
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/aarch64-apple-darwin-ghcup-0.1.17
+              dlHash: b1be8c55838bd0d972e42b02b71bdf47fbbf67be1456e0de2d7d346620538539
         A_ARM:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.2/armv7-linux-ghcup-0.1.16.2
-              dlHash: 983ebb5b584bfa600704216a63f94b40d36a02573834e90ef1042c8472d9ad57
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.17/armv7-linux-ghcup-0.1.17
+              dlHash: fe54ded2fafff4f8d82e511229f257f4c3b87b14c796f9b5b0ea35c359c26cb0
   HLS:
     1.1.0:
       viTags:

docs/CHANGELOG.md

@@ -1,5 +1,19 @@
 # Revision history for ghcup
 
+## 0.1.17 -- 2021-09-20
+
+* Add `--force` option to install/compile wrt [#210](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/210) by Arjun Kathuria
+* Implement compiling HLS from source wrt [#201](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/201)
+* Implement experimental GPG verification of the metadata file (see README) wrt [#263](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/236)
+* Add `ghcup unset` command wrt [#145](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/145)
+* Add `ghcup whereis bindir` etc wrt [#221](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/221)
+* Greatly reduce dependency footprint wrt [#212](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/212)
+* Add `ghcup --plan-json`
+* Improve `--patchdir` option for GHC compilation wrt [#226](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/226)
+* Try to improve logging and failure modes, especially during downloads
+* Add descriptive warnings when HLS and GHC versions are incompatible
+* Improve curl header parsing wrt [#213](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/213)
+
 ## 0.1.16.2 -- 2021-08-12
 
 * Add isolated installations wrt [#141](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/141) by Arjun Kathuria

ghcup.cabal

@@ -1,34 +1,33 @@
-cabal-version:   3.0
-name:            ghcup
-version:         0.1.16.2
-license:         LGPL-3.0-only
-license-file:    LICENSE
-copyright:       Julian Ospald 2020
-maintainer:      hasufell@posteo.de
-author:          Julian Ospald
-homepage:        https://gitlab.haskell.org/haskell/ghcup-hs
-bug-reports:     https://gitlab.haskell.org/haskell/ghcup-hs/issues
-synopsis:        ghc toolchain installer
+cabal-version:      3.0
+name:               ghcup
+version:            0.1.17
+license:            LGPL-3.0-only
+license-file:       LICENSE
+copyright:          Julian Ospald 2020
+maintainer:         hasufell@posteo.de
+author:             Julian Ospald
+homepage:           https://gitlab.haskell.org/haskell/ghcup-hs
+bug-reports:        https://gitlab.haskell.org/haskell/ghcup-hs/issues
+synopsis:           ghc toolchain installer
 description:
   A rewrite of the shell script ghcup, for providing
   a more stable user experience and exposing an API.
 
-category:        System
-build-type:      Simple
+category:           System
+build-type:         Simple
 extra-doc-files:
-  README.md
-  docs/CHANGELOG.md
-  docs/HACKING.md
-  docs/RELEASING.md
   data/config.yaml
   data/metadata/ghcup-0.0.4.yaml
   data/metadata/ghcup-0.0.5.yaml
   data/metadata/ghcup-0.0.6.yaml
-  data/metadata/ghcup-0.0.7.yaml
+  docs/CHANGELOG.md
+  docs/HACKING.md
+  docs/RELEASING.md
+  README.md
 
 extra-source-files:
-  data/build_mk/default
   data/build_mk/cross
+  data/build_mk/default
 
 source-repository head
   type:     git
@@ -103,7 +102,6 @@ library
     , Cabal
     , case-insensitive      ^>=1.2.1.0
     , casing                ^>=0.1.4.1
-    , concurrent-output     ^>=1.10.11
     , containers            ^>=0.6
     , cryptohash-sha256     ^>=0.11.101.0
     , deepseq               ^>=1.4.4.0
@@ -112,6 +110,7 @@ library
     , filepath              ^>=1.4.2.1
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  >=3.0        && <3.2
+    , HsYAML-aeson          ^>=0.2.0.0
     , libarchive            ^>=3.0.0.0
     , lzma-static           ^>=5.2.5.3
     , megaparsec            >=8.0.0      && <9.1
@@ -137,7 +136,6 @@ library
     , vector                ^>=0.12
     , versions              >=4.0.1      && <5.1
     , word8                 ^>=0.1.3
-    , HsYAML-aeson          ^>=0.2.0.0
     , zlib                  ^>=0.6.2.2
 
   if (flag(internal-downloader) && !os(windows))
@@ -159,7 +157,11 @@ library
       , Win32    ^>=2.10
 
   else
-    other-modules: GHCup.Utils.File.Posix
+    other-modules:
+      GHCup.Utils.File.Posix
+      System.Console.Terminal.Common
+      System.Console.Terminal.Posix
+
     build-depends:
       , bz2              >=0.5.0.5 && <1.1
       , unix             ^>=2.7
@@ -199,6 +201,7 @@ executable ghcup
     , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-variant  >=3.0      && <3.2
+    , HsYAML-aeson          ^>=0.2.0.0
     , libarchive            ^>=3.0.0.0
     , megaparsec            >=8.0.0    && <9.1
     , mtl                   ^>=2.2
@@ -213,7 +216,6 @@ executable ghcup
     , uri-bytestring        ^>=0.3.2.2
     , utf8-string           ^>=1.0
     , versions              >=4.0.1    && <5.1
-    , HsYAML-aeson          ^>=0.2.0.0
 
   if flag(internal-downloader)
     cpp-options: -DINTERNAL_DOWNLOADER
@@ -261,6 +263,7 @@ executable ghcup-gen
     , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-variant  >=3.0      && <3.2
+    , HsYAML-aeson          ^>=0.2.0.0
     , libarchive            ^>=3.0.0.0
     , mtl                   ^>=2.2
     , optics                ^>=0.4
@@ -273,7 +276,6 @@ executable ghcup-gen
     , text                  ^>=1.2.4.0
     , transformers          ^>=0.5
     , versions              >=4.0.1    && <5.1
-    , HsYAML-aeson          ^>=0.2.0.0
 
 test-suite ghcup-test
   type:               exitcode-stdio-1.0

lib/GHCup.hs

@@ -34,6 +34,7 @@ import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
 import           GHCup.Utils
 import           GHCup.Utils.File
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 import           GHCup.Utils.Version.QQ
@@ -58,6 +59,7 @@ import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
 import           Data.Maybe
+import           Data.List.NonEmpty             ( NonEmpty((:|)) )
 import           Data.String                    ( fromString )
 import           Data.Text                      ( Text )
 import           Data.Time.Clock
@@ -81,9 +83,7 @@ import           System.Directory        hiding ( findFiles )
 import           System.Environment
 import           System.FilePath
 import           System.IO.Error
-#if defined(IS_WINDOWS)
 import           System.IO.Temp
-#endif
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
@@ -510,7 +510,7 @@ installCabalUnpacked path inst mver' forceInstall = do
   unless forceInstall          -- Overwrite it when it IS a force install
     (liftE $ throwIfFileAlreadyExists destPath)
     
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     (path </> cabalFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -660,7 +660,7 @@ installHLSUnpacked path inst mver' forceInstall = do
     unless forceInstall   -- if it is a force install, overwrite it.
       (liftE $ throwIfFileAlreadyExists destPath)
       
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+    copyFileE
       srcPath
       destPath
     lift $ chmod_755 destPath
@@ -676,7 +676,7 @@ installHLSUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destWrapperPath)
       
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     srcWrapperPath
     destWrapperPath
     
@@ -754,6 +754,8 @@ compileHLS :: ( MonadMask m
            -> Maybe Version
            -> Maybe FilePath
            -> Maybe FilePath
+           -> Maybe FilePath
+           -> Maybe FilePath
            -> Excepts '[ NoDownload
                        , GPGError
                        , DownloadFailed
@@ -764,7 +766,7 @@ compileHLS :: ( MonadMask m
                        , BuildFailed
                        , NotInstalled
                        ] m Version
-compileHLS targetHLS ghcs jobs ov isolateDir cabalProject = do
+compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir = do
   PlatformRequest { .. } <- lift getPlatformReq
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   Dirs { .. } <- lift getDirs
@@ -835,32 +837,48 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject = do
   liftE $ runBuildAction
     workdir
     Nothing
-    (reThrowAll @_ @'[ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
+    (reThrowAll @_ @'[PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
       let installDir = workdir </> "out"
+      liftIO $ createDirRecursive' installDir
+
+      -- apply patches
+      forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
+
+      -- set up project files
+      cp <- case cabalProject of
+        Just cp
+          | isAbsolute cp -> do
+              copyFileE cp (workdir </> "cabal.project")
+              pure "cabal.project"
+          | otherwise -> pure (takeFileName cp)
+        Nothing -> pure "cabal.project"
+      forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local")
+
+      let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"]
 
       artifacts <- forM (sort ghcs) $ \ghc -> do
         let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
-        liftIO $ createDirRecursive' installDir
-        forM_ cabalProject $ \cp -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir </> "cabal.project.local")
+        liftIO $ createDirRecursive' ghcInstallDir
         lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
         liftE $ lEM @_ @'[ProcessError] $
-          execLogged "cabal" ( [ "v2-install"
+          execLogged "cabal" ( [ "v2-build"
                                , "-w"
                                , "ghc-" <> T.unpack (prettyVer ghc)
-                               , "--install-method=copy"
                                ] ++
                                maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
-                               [ "--overwrite-policy=always"
-                               , "--disable-profiling"
-                               , "--disable-tests"
-                               , "--enable-split-sections"
-                               , "--enable-executable-stripping"
-                               , "--enable-executable-static"
-                               , "--installdir=" <> ghcInstallDir
-                               , "exe:haskell-language-server"
-                               , "exe:haskell-language-server-wrapper"]
+                               [ "--project-file=" <> cp
+                               ] ++ targets
                              )
           (Just workdir) "cabal" Nothing
+        forM_ targets $ \target -> do
+          let cabal = "cabal"
+              args = ["list-bin", target]
+          CapturedProcess{..} <- lift $ executeOut cabal args  (Just workdir) 
+          case _exitCode of
+            ExitFailure i -> throwE (NonZeroExit i cabal args)
+            _ -> pure ()
+          let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
+          copyFileE cbin (ghcInstallDir </> takeFileName cbin)
         pure ghcInstallDir
 
       forM_ artifacts $ \artifact -> do
@@ -1021,7 +1039,7 @@ installStackUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destPath)
       
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+  copyFileE
     (path </> stackFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -1210,7 +1228,7 @@ setHLS ver = do
     lift $ rmLink (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
-  bins <- lift $ hlsServerBinaries ver
+  bins <- lift $ hlsServerBinaries ver Nothing
   when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
 
   forM_ bins $ \f -> do
@@ -1318,6 +1336,7 @@ warnAboutHlsCompatibility = do
 -- | Filter data type for 'listVersions'.
 data ListCriteria = ListInstalled
                   | ListSet
+                  | ListAvailable
                   deriving Show
 
 -- | A list result describes a single tool version
@@ -1555,7 +1574,7 @@ listVersions lt' criteria = do
 
   currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
   currentGHCup av =
-    let currentVer = pvpToVersion ghcUpVer
+    let currentVer = fromJust $ pvpToVersion ghcUpVer
         listVer    = Map.lookup currentVer av
         latestVer  = fst <$> headOf (getTagged Latest) av
         recommendedVer = fst <$> headOf (getTagged Latest) av
@@ -1660,6 +1679,7 @@ listVersions lt' criteria = do
     Nothing            -> lr
     Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
     Just ListSet       -> filter (\ListResult {..} -> lSet) lr
+    Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr
 
 
 
@@ -1712,7 +1732,7 @@ rmGHCVer ver = do
       (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
     $ fmap Just
     $ getMajorMinorV (_tvVersion ver)
-  forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
+  forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
     >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
 
   Dirs {..} <- lift getDirs
@@ -2390,7 +2410,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                             <> ".tar"
                             <> takeExtension tar)
     let tarPath = cacheDir </> tarName
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
+    copyFileE (workdir </> tar)
                                                              tarPath
     lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
     pure tarPath
@@ -2520,6 +2540,7 @@ upgradeGHCup :: ( MonadMask m
                 , MonadCatch m
                 , HasLog env
                 , MonadThrow m
+                , MonadFail m
                 , MonadResource m
                 , MonadIO m
                 , MonadUnliftIO m
@@ -2544,7 +2565,8 @@ upgradeGHCup mtarget force' = do
 
   lift $ logInfo "Upgrading GHCup..."
   let latestVer = fromJust $ fst <$> getLatest dls GHCup
-  when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
+  (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer
+  when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
   dli   <- liftE $ getDownloadInfo GHCup latestVer
   tmp   <- lift withGHCupTmpDir
   let fn = "ghcup" <> exeExt
@@ -2556,7 +2578,7 @@ upgradeGHCup mtarget force' = do
   lift $ logDebug $ "rm -f " <> T.pack destFile
   lift $ hideError NoSuchThing $ recycleFile destFile
   lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
+  copyFileE p
                                                            destFile
   lift $ chmod_755 destFile
 
@@ -2607,7 +2629,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
     handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
     $ fmap Just
     $ getMajorMinorV _tvVersion
-  forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
+  forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
     >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
 
 
@@ -2681,3 +2703,134 @@ throwIfFileAlreadyExists :: ( MonadIO m ) =>
 throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp)
                                 (throwE $ FileAlreadyExistsError fp)
 
+
+
+    --------------------------
+    --[ Garbage collection ]--
+    --------------------------
+
+
+rmOldGHC :: ( MonadReader env m
+            , HasGHCupInfo env
+            , HasDirs env
+            , HasLog env
+            , MonadIO m
+            , MonadFail m
+            , MonadMask m
+            , MonadUnliftIO m
+            )
+         => Excepts '[NotInstalled] m ()
+rmOldGHC = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+  let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
+  ghcs <- lift $ fmap rights getInstalledGHCs
+  forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc
+
+
+
+rmProfilingLibs :: ( MonadReader env m
+                   , HasDirs env
+                   , HasLog env
+                   , MonadIO m
+                   , MonadFail m
+                   , MonadMask m
+                   , MonadUnliftIO m
+                   )
+                => m ()
+rmProfilingLibs = do
+  ghcs <- fmap rights getInstalledGHCs
+
+  let regexes :: [ByteString]
+      regexes = [[s|.*_p\.a$|], [s|.*\.p_hi$|]]
+
+  forM_ regexes $ \regex ->
+    forM_ ghcs $ \ghc -> do
+      d <- ghcupGHCDir ghc
+      matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
+        d
+        (makeRegexOpts compExtended
+                       execBlank
+                       regex
+        )
+      forM_ matches $ \m -> do
+        let p = d </> m
+        logDebug $ "rm " <> T.pack p
+        rmFile p
+
+
+
+rmShareDir :: ( MonadReader env m
+              , HasDirs env
+              , HasLog env
+              , MonadIO m
+              , MonadFail m
+              , MonadMask m
+              , MonadUnliftIO m
+              )
+           => m ()
+rmShareDir = do
+  ghcs <- fmap rights getInstalledGHCs
+  forM_ ghcs $ \ghc -> do
+    d <- ghcupGHCDir ghc
+    let p = d </> "share"
+    logDebug $ "rm -rf " <> T.pack p
+    rmPathForcibly p
+
+
+rmHLSNoGHC :: ( MonadReader env m
+              , HasDirs env
+              , HasLog env
+              , MonadIO m
+              , MonadMask m
+              )
+           => m ()
+rmHLSNoGHC = do
+  Dirs {..} <- getDirs
+  ghcs <- fmap rights getInstalledGHCs
+  hlses <- fmap rights getInstalledHLSs
+  forM_ hlses $ \hls -> do
+    hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls
+    forM_ hlsGHCs $ \ghc -> do 
+      when (ghc `notElem` ghcs) $ do
+        bins <- hlsServerBinaries hls (Just $ _tvVersion ghc)
+        forM_ bins $ \bin -> do
+          let f = binDir </> bin
+          logDebug $ "rm " <> T.pack f
+          rmFile f
+
+
+rmCache :: ( MonadReader env m
+           , HasDirs env
+           , HasLog env
+           , MonadIO m
+           , MonadMask m
+           )
+        => m ()
+rmCache = do
+  Dirs {..} <- getDirs
+  contents <- liftIO $ listDirectory cacheDir
+  forM_ contents $ \f -> do
+    let p = cacheDir </> f
+    logDebug $ "rm " <> T.pack p
+    rmFile p
+
+
+rmTmp :: ( MonadReader env m
+         , HasDirs env
+         , HasLog env
+         , MonadIO m
+         , MonadMask m
+         )
+      => m ()
+rmTmp = do
+  tmpdir <- liftIO getCanonicalTemporaryDirectory
+  ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles
+    tmpdir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^ghcup-.*$|] :: ByteString)
+    )
+  forM_ ghcup_dirs $ \f -> do
+    let p = tmpdir </> f
+    logDebug $ "rm -rf " <> T.pack p
+    rmPathForcibly p

lib/GHCup/Download.hs

@@ -35,6 +35,7 @@ import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
 import           GHCup.Utils.File
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Version
 

lib/GHCup/Platform.hs

@@ -23,6 +23,7 @@ import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.File
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 
@@ -138,7 +139,6 @@ getLinuxDistro = do
         | hasWord name ["exherbo"] -> Exherbo
         | hasWord name ["gentoo"]  -> Gentoo
         | hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
-        | hasWord name ["solus"]   -> Solus
         | otherwise                -> UnknownLinux
   pure (distro, parsedVer)
  where

lib/GHCup/Types.hs

@@ -223,7 +223,6 @@ data LinuxDistro = Debian
                  | RedHat
                  | Alpine
                  | AmazonLinux
-                 | Solus
                  -- rolling
                  | Gentoo
                  | Exherbo
@@ -243,7 +242,6 @@ distroToString CentOS = "centos"
 distroToString RedHat = "redhat"
 distroToString Alpine = "alpine"
 distroToString AmazonLinux = "amazon"
-distroToString Solus = "solus"
 distroToString Gentoo = "gentoo"
 distroToString Exherbo = "exherbo"
 distroToString UnknownLinux = "unknown"
@@ -419,6 +417,7 @@ data Settings = Settings
   , urlSource  :: URLSource
   , noNetwork  :: Bool
   , gpgSetting :: GPGSetting
+  , noColor    :: Bool -- this also exists in LoggerConfig
   }
   deriving (Show, GHC.Generic)
 
@@ -578,11 +577,12 @@ data LogLevel = Warn
   deriving (Eq, Ord, Show)
 
 data LoggerConfig = LoggerConfig
-  { lcPrintDebug :: Bool                  -- ^ whether to print debug in colorOutter
-  , colorOutter  :: T.Text -> IO () -- ^ how to write the color output
-  , rawOutter    :: T.Text -> IO () -- ^ how to write the full raw output
+  { lcPrintDebug   :: Bool            -- ^ whether to print debug in colorOutter
+  , consoleOutter  :: T.Text -> IO () -- ^ how to write the console output
+  , fileOutter     :: T.Text -> IO () -- ^ how to write the file output
+  , fancyColors    :: Bool
   }
   deriving Show
 
 instance NFData LoggerConfig where
-  rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug
+  rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)

lib/GHCup/Types/JSON.hs

@@ -24,6 +24,8 @@ module GHCup.Types.JSON where
 import           GHCup.Types
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger             () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
+                                                   -- This is due to the boot file.
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson

lib/GHCup/Types/Optics.hs

@@ -23,12 +23,9 @@ import           GHCup.Types
 
 import           Control.Monad.Reader
 import           Data.ByteString         ( ByteString )
-import           Data.Text               ( Text )
 import           Optics
 import           URI.ByteString
-import           System.Console.Pretty
 
-import qualified Data.Text                     as T
 
 makePrisms ''Tool
 makePrisms ''Architecture
@@ -117,80 +114,6 @@ getDirs :: ( MonadReader env m
 getDirs = gets @"dirs"
 
 
-logInfo :: ( MonadReader env m
-           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-           , MonadIO m
-           )
-        => Text
-        -> m ()
-logInfo = logInternal Info
-
-logWarn :: ( MonadReader env m
-           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-           , MonadIO m
-           )
-        => Text
-        -> m ()
-logWarn = logInternal Warn
-
-logDebug :: ( MonadReader env m
-            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-            , MonadIO m
-            )
-         => Text
-         -> m ()
-logDebug = logInternal Debug
-
-logError :: ( MonadReader env m
-            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-            , MonadIO m
-            )
-         => Text
-         -> m ()
-logError = logInternal Error
-
-
-logInternal :: ( MonadReader env m
-               , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-               , MonadIO m
-               ) => LogLevel
-                 -> Text
-                 -> m ()
-logInternal logLevel msg = do
-  LoggerConfig {..} <- gets @"loggerConfig"
-  let style' = case logLevel of
-        Debug   -> style Bold . color Blue
-        Info    -> style Bold . color Green
-        Warn    -> style Bold . color Yellow
-        Error   -> style Bold . color Red
-  let l = case logLevel of
-        Debug   -> style' "[ Debug ]"
-        Info    -> style' "[ Info  ]"
-        Warn    -> style' "[ Warn  ]"
-        Error   -> style' "[ Error ]"
-  let strs = T.split (== '\n') msg
-  let out = case strs of
-              [] -> T.empty
-              (x:xs) -> 
-                  foldr (\a b -> a <> "\n" <> b) mempty
-                . ((l <> " " <> x) :)
-                . fmap (\line' -> style' "[ ...   ] " <> line' )
-                $ xs
-
-  when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
-    $ liftIO $ colorOutter out
-
-  -- raw output
-  let lr = case logLevel of
-        Debug   -> "Debug:"
-        Info    -> "Info:"
-        Warn    -> "Warn:"
-        Error   -> "Error:"
-  let outr = lr <> " " <> msg <> "\n"
-  liftIO $ rawOutter outr
-
-
-
 getLogCleanup :: ( MonadReader env m
                  , LabelOptic' "logCleanup" A_Lens env (IO ())
                  )

lib/GHCup/Utils.hs

@@ -35,6 +35,7 @@ import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
 import           GHCup.Utils.File
+import           GHCup.Utils.Logger
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
@@ -85,8 +86,37 @@ import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
+import qualified Data.List.NonEmpty            as NE
 
 
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XDataKinds
+-- >>> :set -XTypeApplications
+-- >>> :set -XQuasiQuotes
+-- >>> import System.Directory
+-- >>> import URI.ByteString
+-- >>> import qualified Data.Text as T
+-- >>> import GHCup.Utils.Prelude
+-- >>> import GHCup.Download
+-- >>> import GHCup.Version
+-- >>> import GHCup.Errors
+-- >>> import GHCup.Types
+-- >>> import GHCup.Types.Optics
+-- >>> import Optics
+-- >>> import GHCup.Utils.Version.QQ
+-- >>> import qualified Data.Text.Encoding as E
+-- >>> import Control.Monad.Reader
+-- >>> import Haskus.Utils.Variant.Excepts
+-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
+-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
+-- >>> dirs' <- getAllDirs
+-- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ]
+-- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False
+-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
+-- >>> cwd <- getCurrentDirectory
+-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
+-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref
 
 
 
@@ -462,33 +492,50 @@ hlsGHCVersions :: ( MonadReader env m
                   )
                => m [Version]
 hlsGHCVersions = do
-  h                             <- hlsSet
-  vers                          <- forM h $ \h' -> do
-    bins <- hlsServerBinaries h'
-    pure $ fmap
-      (version
-        . T.pack
-        . fromJust
-        . stripPrefix "haskell-language-server-"
-        . head
-        . splitOn "~"
-        )
-      bins
-  pure . sortBy (flip compare) . rights . concat . maybeToList $ vers
+  h <- hlsSet
+  fromMaybe [] <$> forM h hlsGHCVersions'
+
+
+hlsGHCVersions' :: ( MonadReader env m
+                   , HasDirs env
+                   , MonadIO m
+                   , MonadThrow m
+                   , MonadCatch m
+                   )
+                => Version
+                -> m [Version]
+hlsGHCVersions' v' = do
+  bins <- hlsServerBinaries v' Nothing
+  let vers = fmap
+        (version
+          . T.pack
+          . fromJust
+          . stripPrefix "haskell-language-server-"
+          . head
+          . splitOn "~"
+          )
+        bins
+  pure . sortBy (flip compare) . rights $ vers
 
 
 -- | Get all server binaries for an hls version, if any.
 hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
                   => Version
+                  -> Maybe Version   -- ^ optional GHC version
                   -> m [FilePath]
-hlsServerBinaries ver = do
+hlsServerBinaries ver mghcVer = do
   Dirs {..}  <- getDirs
   liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts
       compExtended
       execBlank
-      ([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
+      ([s|^haskell-language-server-|]
+        <> maybe [s|.*|] escapeVerRex mghcVer
+        <> [s|~|]
+        <> escapeVerRex ver
+        <> E.encodeUtf8 (T.pack exeExt)
+        <> [s|$|] :: ByteString
       )
     )
 
@@ -517,7 +564,7 @@ hlsWrapperBinary ver = do
 -- | Get all binaries for an hls version, if any.
 hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
 hlsAllBinaries ver = do
-  hls     <- hlsServerBinaries ver
+  hls     <- hlsServerBinaries ver Nothing
   wrapper <- hlsWrapperBinary ver
   pure (maybeToList wrapper ++ hls)
 
@@ -558,34 +605,83 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
   Just (x, y) -> x == major' && y == minor'
   Nothing     -> False
 
+-- | Match PVP prefix.
+--
+-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
+-- True
+-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
+-- True
+-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
+-- False
+-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
+-- True
+matchPVPrefix :: PVP -> PVP -> Bool
+matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
 
--- | Get the latest installed full GHC version that satisfies X.Y.
--- This reads `ghcupGHCBaseDir`.
-getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
-               => Int        -- ^ major version component
-               -> Int        -- ^ minor version component
-               -> Maybe Text -- ^ the target triple
-               -> m (Maybe GHCTargetVersion)
-getGHCForMajor major' minor' mt = do
+toL :: PVP -> [Int]
+toL (PVP inner) = fmap fromIntegral $ NE.toList inner
+
+
+-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
+-- PVP version.
+getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
+             => PVP
+             -> Maybe Text -- ^ the target triple
+             -> m (Maybe GHCTargetVersion)
+getGHCForPVP pvpIn mt = do
   ghcs <- rights <$> getInstalledGHCs
+  -- we're permissive here... failed parse just means we have no match anyway
+  let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
+        pvp_ <- versionToPVP _tvVersion
+        pure (pvp_, _tvTarget)
 
-  pure
-    . lastMay
-    . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
-    . filter
-        (\GHCTargetVersion {..} ->
-          _tvTarget == mt && matchMajor _tvVersion major' minor'
-        )
-    $ ghcs
+  getGHCForPVP' pvpIn ghcs' mt
+
+-- | Like 'getGHCForPVP', except with explicit input parameter.
+--
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing
+-- "Just 8.10.7"
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
+-- "Just 8.8.4"
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
+-- "Just 8.10.4"
+getGHCForPVP' :: MonadThrow m
+             => PVP
+             -> [(PVP, Maybe Text)] -- ^ installed GHCs
+             -> Maybe Text          -- ^ the target triple
+             -> m (Maybe GHCTargetVersion)
+getGHCForPVP' pvpIn ghcs' mt = do
+  let mResult = lastMay
+                  . sortBy (\(x, _) (y, _) -> compare x y)
+                  . filter
+                      (\(pvp_, target) ->
+                        target == mt && matchPVPrefix pvp_ pvpIn
+                      )
+                  $ ghcs'
+  forM mResult $ \(pvp_, target) -> do
+    ver' <- pvpToVersion pvp_
+    pure (GHCTargetVersion target ver')
 
 
--- | Get the latest available ghc for X.Y major version.
-getLatestGHCFor :: Int -- ^ major version component
-                -> Int -- ^ minor version component
-                -> GHCupDownloads
-                -> Maybe (Version, VersionInfo)
-getLatestGHCFor major' minor' dls =
-  preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
+-- | Get the latest available ghc for the given PVP version, which
+-- may only contain parts.
+--
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r
+-- Just (PVP {_pComponents = 8 :| [10,7]})
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r
+-- Just (PVP {_pComponents = 8 :| [8,4]})
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r
+-- Just (PVP {_pComponents = 8 :| [8,4]})
+getLatestToolFor :: MonadThrow m
+                 => Tool
+                 -> PVP
+                 -> GHCupDownloads
+                 -> m (Maybe (PVP, VersionInfo))
+getLatestToolFor tool pvpIn dls = do
+  let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
+  let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
+  pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps
+
 
 
 
@@ -689,11 +785,10 @@ intoSubdir bdir tardir = case tardir of
 -- | Get the tool version that has this tag. If multiple have it,
 -- picks the greatest version.
 getTagged :: Tag
-          -> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
+          -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo)
 getTagged tag =
-  to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
-  % to Map.toDescList
-  % _head
+  to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
+  % folding id
 
 getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
 getLatest av tool = headOf (ix tool % getTagged Latest) av
@@ -824,7 +919,7 @@ getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI
 getChangeLog dls tool (Left v') =
   preview (ix tool % ix v' % viChangeLog % _Just) dls
 getChangeLog dls tool (Right tag) =
-  preview (ix tool % getTagged tag % to snd % viChangeLog % _Just) dls
+  preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls
 
 
 -- | Execute a build action while potentially cleaning up:

lib/GHCup/Utils/Dirs.hs

@@ -38,6 +38,7 @@ import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
 import           GHCup.Utils.MegaParsec
+import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 
 import           Control.Exception.Safe

lib/GHCup/Utils/File/Common.hs

@@ -105,6 +105,11 @@ findFiles path regex = do
   contents <- listDirectory path
   pure $ filter (match regex) contents
 
+findFilesDeep :: FilePath -> Regex -> IO [FilePath]
+findFilesDeep path regex = do
+  contents <- getDirectoryContentsRecursive path
+  pure $ filter (match regex) contents
+
 findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
 findFiles' path parser = do
   contents <- listDirectory path

lib/GHCup/Utils/File/Common.hs-boot

@@ -0,0 +1,5 @@
+module GHCup.Utils.File.Common where
+
+import           Text.Regex.Posix
+
+findFiles :: FilePath -> Regex -> IO [FilePath]

lib/GHCup/Utils/File/Posix.hs

@@ -17,6 +17,7 @@ module GHCup.Utils.File.Posix where
 
 import           GHCup.Utils.File.Common
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
 
@@ -34,8 +35,7 @@ import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
 import           GHC.IO.Exception
-import           System.Console.Pretty   hiding ( Pretty )
-import           System.Console.Regions
+import           System.Console.Terminal.Common
 import           System.IO.Error
 import           System.FilePath
 import           System.Directory
@@ -51,6 +51,7 @@ import qualified Data.Sequence                 as Sq
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified System.Posix.Process          as SPP
+import qualified System.Console.Terminal.Posix as TP
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified "unix-bytestring" System.Posix.IO.ByteString
@@ -87,9 +88,9 @@ execLogged exe args chdir lfile env = do
   let logfile = logsDir </> lfile <> ".log"
   liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
                    closeFd
-                   (action verbose)
+                   (action verbose noColor)
  where
-  action verbose fd = do
+  action verbose no_color fd = do
     actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
       -- start the thread that logs to stdout
       pState <- newEmptyMVar
@@ -100,7 +101,7 @@ execLogged exe args chdir lfile env = do
         $ EX.finally
             (if verbose
               then tee fd stdoutRead
-              else printToRegion fd stdoutRead 6 pState
+              else printToRegion fd stdoutRead 6 pState no_color
             )
             (putMVar done ())
 
@@ -137,46 +138,57 @@ execLogged exe args chdir lfile env = do
 
   -- Reads fdIn and logs the output in a continous scrolling area
   -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
-  printToRegion fileFd fdIn size pState = do
-    void $ displayConsoleRegions $ do
-      rs <-
-        liftIO
-        . fmap Sq.fromList
-        . sequence
-        . replicate size
-        . openConsoleRegion
-        $ Linear
-      flip runStateT mempty
-        $ handle
-            (\(ex :: SomeException) -> do
-              ps <- liftIO $ takeMVar pState
-              when ps (forM_ rs (liftIO . closeConsoleRegion))
-              throw ex
-            )
-        $ readTilEOF (lineAction rs) fdIn
+  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
+  printToRegion fileFd fdIn size pState no_color = do
+    -- init region
+    forM_ [1..size] $ \_ -> BS.putStr "\n"
+
+    void $ flip runStateT mempty
+      $ do
+        handle
+          (\(ex :: SomeException) -> do
+            ps <- liftIO $ takeMVar pState
+            when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen))
+            throw ex
+          ) $ readTilEOF lineAction fdIn
 
    where
+    clearScreen :: ByteString
+    clearScreen = "\x1b[0J"
+    clearLine :: ByteString
+    clearLine = "\x1b[2K"
+    moveLineUp :: Int -> ByteString
+    moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"
+    moveLineDown :: Int -> ByteString
+    moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"
+    pos1 :: ByteString
+    pos1 = "\r"
+    overwriteNthLine :: Int -> ByteString -> ByteString
+    overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
+
+    blue :: ByteString -> ByteString
+    blue bs 
+      | no_color = bs
+      | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
+
     -- action to perform line by line
-    -- TODO: do this with vty for efficiency
     lineAction :: (MonadMask m, MonadIO m)
-               => Seq ConsoleRegion
-               -> ByteString
+               => ByteString
                -> StateT (Seq ByteString) m ()
-    lineAction rs = \bs' -> do
+    lineAction = \bs' -> do
       void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
       modify (swapRegs bs')
-      regs <- get
-      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
-        w <- consoleWidth
-        return
-          . T.pack
-          . color Blue
-          . T.unpack
-          . decUTF8Safe
-          . trim w
-          . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
-          $ bs
+      liftIO TP.size >>= \case
+        Nothing -> pure ()
+        Just (Window _ w) -> do
+          regs <- get
+          liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
+              BS.putStr
+              . overwriteNthLine (size - i)
+              . trim w
+              . blue
+              . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
+              $ bs
 
     swapRegs :: a -> Seq a -> Seq a
     swapRegs bs = \regs -> if

lib/GHCup/Utils/Logger.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE OverloadedStrings   #-}
 
 {-|
 Module      : GHCup.Utils.Logger
@@ -16,21 +18,97 @@ module GHCup.Utils.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
-import           GHCup.Utils.File
+import {-# SOURCE #-} GHCup.Utils.File.Common
 import           GHCup.Utils.String.QQ
 
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
+import           Data.Text               ( Text )
+import           Optics
 import           Prelude                 hiding ( appendFile )
+import           System.Console.Pretty
 import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
 import GHCup.Utils.Prelude
+import qualified Data.Text                     as T
 
+logInfo :: ( MonadReader env m
+           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+           , MonadIO m
+           )
+        => Text
+        -> m ()
+logInfo = logInternal Info
+
+logWarn :: ( MonadReader env m
+           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+           , MonadIO m
+           )
+        => Text
+        -> m ()
+logWarn = logInternal Warn
+
+logDebug :: ( MonadReader env m
+            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+            , MonadIO m
+            )
+         => Text
+         -> m ()
+logDebug = logInternal Debug
+
+logError :: ( MonadReader env m
+            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+            , MonadIO m
+            )
+         => Text
+         -> m ()
+logError = logInternal Error
+
+
+logInternal :: ( MonadReader env m
+               , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+               , MonadIO m
+               ) => LogLevel
+                 -> Text
+                 -> m ()
+logInternal logLevel msg = do
+  LoggerConfig {..} <- gets @"loggerConfig"
+  let color' c = if fancyColors then color c else id
+  let style' = case logLevel of
+        Debug   -> style Bold . color' Blue
+        Info    -> style Bold . color' Green
+        Warn    -> style Bold . color' Yellow
+        Error   -> style Bold . color' Red
+  let l = case logLevel of
+        Debug   -> style' "[ Debug ]"
+        Info    -> style' "[ Info  ]"
+        Warn    -> style' "[ Warn  ]"
+        Error   -> style' "[ Error ]"
+  let strs = T.split (== '\n') msg
+  let out = case strs of
+              [] -> T.empty
+              (x:xs) -> 
+                  foldr (\a b -> a <> "\n" <> b) mempty
+                . ((l <> " " <> x) :)
+                . fmap (\line' -> style' "[ ...   ] " <> line' )
+                $ xs
+
+  when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
+    $ liftIO $ consoleOutter out
+
+  -- raw output
+  let lr = case logLevel of
+        Debug   -> "Debug:"
+        Info    -> "Info:"
+        Warn    -> "Warn:"
+        Error   -> "Error:"
+  let outr = lr <> " " <> msg <> "\n"
+  liftIO $ fileOutter outr
 
 
 initGHCupFileLogging :: ( MonadReader env m

lib/GHCup/Utils/Logger.hs-boot

@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE OverloadedStrings   #-}
+
+module GHCup.Utils.Logger where
+
+import           GHCup.Types
+
+import           Control.Monad.IO.Class
+import           Control.Monad.Reader
+import           Data.Text               ( Text )
+import           Optics
+
+logWarn :: ( MonadReader env m
+           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
+           , MonadIO m
+           )
+        => Text
+        -> m ()
+

lib/GHCup/Utils/Prelude.hs

@@ -22,7 +22,9 @@ module GHCup.Utils.Prelude where
 #if defined(IS_WINDOWS)
 import           GHCup.Types
 #endif
+import           GHCup.Errors
 import           GHCup.Types.Optics
+import {-# SOURCE #-} GHCup.Utils.Logger
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -31,13 +33,14 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf )
+import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
 import           Data.Maybe
 import           Data.Foldable
+import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           Data.Word8
+import           Data.Word8                  hiding ( isDigit )
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
@@ -58,6 +61,7 @@ import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
 import qualified Data.List.Split               as Split
+import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -295,12 +299,28 @@ removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
 
 
-pvpToVersion :: PVP -> Version
+pvpToVersion :: MonadThrow m => PVP -> m Version
 pvpToVersion =
-  either (\_ -> error "Couldn't convert PVP to Version") id
-    . version
-    . prettyPVP
+  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP
 
+versionToPVP :: MonadThrow m => Version -> m PVP
+versionToPVP v = either (\_ -> alternative v) pure . pvp . prettyVer $ v
+ where
+  alternative :: MonadThrow m => Version -> m PVP
+  alternative v' = case NE.takeWhile isDigit (_vChunks v') of
+    [] -> throwM $ ParseError "Couldn't convert Version to PVP"
+    xs -> pure $ pvpFromList (unsafeDigit <$> xs)
+
+  isDigit :: VChunk -> Bool
+  isDigit (Digits _ :| []) = True
+  isDigit _                = False
+
+  unsafeDigit :: VChunk -> Int
+  unsafeDigit (Digits x :| []) = fromIntegral x
+  unsafeDigit _ = error "unsafeDigit: wrong input"
+
+pvpFromList :: [Int] -> PVP
+pvpFromList = PVP . NE.fromList . fmap fromIntegral
 
 -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
 -- the Unicode replacement character U+FFFD.
@@ -508,6 +528,10 @@ recover action =
 #endif
 
 
+copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
+copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
+
+
 -- | Gathering monoidal values
 --
 -- >>> traverseFold (pure . (:["0"])) ["1","2"]
@@ -528,6 +552,8 @@ forFold = \t -> (`traverseFold` t)
 --
 -- >>> stripNewline "foo\n\n\n"
 -- "foo"
+-- >>> stripNewline "foo\n\n\nfoo"
+-- "foofoo"
 -- >>> stripNewline "foo\r"
 -- "foo"
 -- >>> stripNewline "foo"
@@ -539,10 +565,29 @@ stripNewline :: String -> String
 stripNewline = filter (`notElem` "\n\r")
 
 
+-- | Strip @\\r@ and @\\n@ from end of 'String'.
+--
+-- >>> stripNewlineEnd "foo\n\n\n"
+-- "foo"
+-- >>> stripNewlineEnd "foo\n\n\nfoo"
+-- "foo\n\n\nfoo"
+-- >>> stripNewlineEnd "foo\r"
+-- "foo"
+-- >>> stripNewlineEnd "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
+stripNewlineEnd :: String -> String
+stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
+
+
 -- | Strip @\\r@ and @\\n@ from 'Text's
 --
 -- >>> stripNewline' "foo\n\n\n"
 -- "foo"
+-- >>> stripNewline' "foo\n\n\nfoo"
+-- "foofoo"
 -- >>> stripNewline' "foo\r"
 -- "foo"
 -- >>> stripNewline' "foo"

lib/GHCup/Version.hs

@@ -28,7 +28,7 @@ import qualified Data.Text                     as T
 -- Note that when updating this, CI requires that the file exsists AND the same file exists at
 -- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added.
 ghcupURL :: URI
-ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.7.yaml|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.6.yaml|]
 
 -- | The current ghcup version.
 ghcUpVer :: PVP

lib/System/Console/Terminal/Common.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+#if __GLASGOW_HASKELL__ >= 702
+#define LANGUAGE_DeriveGeneric
+{-# LANGUAGE DeriveGeneric #-}
+#endif
+
+module System.Console.Terminal.Common
+  ( Window(..)
+  ) where
+
+import Data.Data (Typeable, Data)
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Foldable (Foldable)
+import Data.Traversable (Traversable)
+#endif
+
+#ifdef LANGUAGE_DeriveGeneric
+import GHC.Generics
+  ( Generic
+#if __GLASGOW_HASKELL__ >= 706
+  , Generic1
+#endif
+  )
+#endif
+
+-- | Terminal window width and height
+data Window a = Window
+  { height :: !a
+  , width  :: !a
+  } deriving
+    ( Show, Eq, Read, Data, Typeable
+    , Foldable, Functor, Traversable
+#ifdef LANGUAGE_DeriveGeneric
+    , Generic
+#if __GLASGOW_HASKELL__ >= 706
+    , Generic1
+#endif
+#endif
+    )

lib/System/Console/Terminal/Posix.hsc

@@ -0,0 +1,65 @@
+{-# LANGUAGE CApiFFI #-}
+
+module System.Console.Terminal.Posix
+  ( size, fdSize, hSize
+  ) where
+
+import System.Console.Terminal.Common
+import Control.Exception (catch)
+import Data.Typeable (cast)
+import Foreign
+import Foreign.C.Error
+import Foreign.C.Types
+import GHC.IO.FD (FD(FD, fdFD))
+import GHC.IO.Handle.Internals (withHandle_)
+import GHC.IO.Handle.Types (Handle, Handle__(Handle__, haDevice))
+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)
+import Prelude hiding (catch)
+#endif
+import System.Posix.Types (Fd(Fd))
+
+#include <sys/ioctl.h>
+#include <unistd.h>
+
+
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+
+
+-- Interesting part of @struct winsize@
+data CWin = CWin CUShort CUShort
+
+instance Storable CWin where
+  sizeOf _ = (#size struct winsize)
+  alignment _ = (#alignment struct winsize)
+  peek ptr = do
+    row <- (#peek struct winsize, ws_row) ptr
+    col <- (#peek struct winsize, ws_col) ptr
+    return $ CWin row col
+  poke ptr (CWin row col) = do
+    (#poke struct winsize, ws_row) ptr row
+    (#poke struct winsize, ws_col) ptr col
+
+
+fdSize :: Integral n => Fd -> IO (Maybe (Window n))
+fdSize (Fd fd) = with (CWin 0 0) $ \ws -> do
+  _ <- throwErrnoIfMinus1 "ioctl" $
+    ioctl fd (#const TIOCGWINSZ) ws
+  CWin row col <- peek ws
+  return . Just $ Window (fromIntegral row) (fromIntegral col)
+ `catch`
+  handler
+ where
+  handler :: IOError -> IO (Maybe (Window h))
+  handler _ = return Nothing
+
+foreign import capi "sys/ioctl.h ioctl"
+  ioctl :: CInt -> CULong -> Ptr CWin -> IO CInt
+
+size :: Integral n => IO (Maybe (Window n))
+size = fdSize (Fd (#const STDOUT_FILENO))
+
+hSize :: Integral n => Handle -> IO (Maybe (Window n))
+hSize h = withHandle_ "hSize" h $ \Handle__ { haDevice = dev } ->
+  case cast dev of
+    Nothing -> return Nothing
+    Just FD { fdFD = fd } -> fdSize (Fd fd)

scripts/bootstrap/bootstrap-haskell

@@ -21,7 +21,7 @@
 
 plat="$(uname -s)"
 arch=$(uname -m)
-ghver="0.1.16.2"
+ghver="0.1.17"
 base_url="https://downloads.haskell.org/~ghcup"
 
 export GHCUP_SKIP_UPDATE_CHECK=yes
@@ -52,41 +52,57 @@ esac
 
 
 die() {
-    (>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
+    if [ -n "${NO_COLOR}" ] ; then
+        (>&2 printf "%s\\n" "$1")
+    else
+        (>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
+    fi
     exit 2
 }
 
 warn() {
-	case "${plat}" in
-			MSYS*|MINGW*)
-				echo -e "\\033[0;35m$1\\033[0m"
-				;;
-			*)
-				printf "\\033[0;35m%s\\033[0m\\n" "$1"
-				;;
-	esac
+    if [ -n "${NO_COLOR}" ] ; then
+        printf "%s\\n" "$1"
+    else
+        case "${plat}" in
+                MSYS*|MINGW*)
+                    echo -e "\\033[0;35m$1\\033[0m"
+                    ;;
+                *)
+                    printf "\\033[0;35m%s\\033[0m\\n" "$1"
+                    ;;
+        esac
+    fi
 }
 
 yellow() {
-	case "${plat}" in
-			MSYS*|MINGW*)
-				echo -e "\\033[0;33m$1\\033[0m"
-				;;
-			*)
-				printf "\\033[0;33m%s\\033[0m\\n" "$1"
-				;;
-	esac
+    if [ -n "${NO_COLOR}" ] ; then
+        printf "%s\\n" "$1"
+    else
+        case "${plat}" in
+                MSYS*|MINGW*)
+                    echo -e "\\033[0;33m$1\\033[0m"
+                    ;;
+                *)
+                    printf "\\033[0;33m%s\\033[0m\\n" "$1"
+                    ;;
+        esac
+    fi
 }
 
 green() {
-	case "${plat}" in
-			MSYS*|MINGW*)
-				echo -e "\\033[0;32m$1\\033[0m"
-				;;
-			*)
-				printf "\\033[0;32m%s\\033[0m\\n" "$1"
-				;;
-	esac
+    if [ -n "${NO_COLOR}" ] ; then
+        printf "%s\\n" "$1"
+    else
+        case "${plat}" in
+                MSYS*|MINGW*)
+                    echo -e "\\033[0;32m$1\\033[0m"
+                    ;;
+                *)
+                    printf "\\033[0;32m%s\\033[0m\\n" "$1"
+                    ;;
+        esac
+    fi
 }
 
 edo() {

stack.yaml

@@ -4,9 +4,6 @@ packages:
   - .
 
 extra-deps:
-  - git: https://github.com/bgamari/terminal-size
-    commit: 34ea816bd63f75f800eedac12c6908c6f3736036
-
   - git: https://github.com/hasufell/libarchive
     commit: 8587aab78dd515928024ecd82c8f215e06db85cd