Fix arch detection on macos

This fixes unix socket errors, because there's a max path length for
those.

.gitlab-ci.yml

@@ -182,12 +182,12 @@ variables:
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
 
     # make sure to not pollute the machine with temp files etc
-    - mkdir -p $CI_PROJECT_DIR/.bc
+    - mkdir -p $CI_PROJECT_DIR/.brew_cache
-    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
-    - mkdir -p $CI_PROJECT_DIR/.bl
+    - mkdir -p $CI_PROJECT_DIR/.brew_logs
-    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
-    - mkdir -p $CI_PROJECT_DIR/.bt
+    - mkdir -p /private/tmp/.brew_tmp
-    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
+    - export HOMEBREW_TEMP=/private/tmp/.brew_tmp
 
     # update and install packages
     - brew update
@@ -541,12 +541,12 @@ release:darwin:aarch64:
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
 
     # make sure to not pollute the machine with temp files etc
-    - mkdir -p $CI_PROJECT_DIR/.bc
+    - mkdir -p $CI_PROJECT_DIR/.brew_cache
-    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
-    - mkdir -p $CI_PROJECT_DIR/.bl
+    - mkdir -p $CI_PROJECT_DIR/.brew_logs
-    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
-    - mkdir -p $CI_PROJECT_DIR/.bt
+    - mkdir -p /private/tmp/.brew_tmp
-    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
+    - export HOMEBREW_TEMP=/private/tmp/.brew_tmp
 
     # update and install packages
     - brew update

.gitlab/after_script.sh

@@ -12,4 +12,8 @@ if [ "${OS}" = "WINDOWS" ] ; then
 	rm -Rf /c/ghcup
 fi
 
+if [ "${OS}" = "DARWIN" ] ; then
+	rm -Rf /private/tmp/.brew_tmp
+fi
+
 exit 0

.gitlab/script/ghcup_hls.sh

@@ -43,7 +43,7 @@ cabal --version
 
 eghcup debug-info
 
-eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} ${GHC_VERSION}
+eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} --ghc ${GHC_VERSION}
 
 [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version` = "${HLS_TARGET_VERSION}" ] || [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version | sed 's/.0$//'` = "${HLS_TARGET_VERSION}" ]
 

CHANGELOG.md

@@ -1,5 +1,14 @@
 # Revision history for ghcup
 
+## 0.1.17.4 -- 2021-11-13
+
+* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)
+* make upgrading ghcup in TUI more pleasant wrt [#276](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/276)
+* fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`)
+* fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245)
+* redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files
+* avoid redundant update warnings wrt [#283](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283)
+
 ## 0.1.17.3 -- 2021-10-27
 
 * clean up during unpack failures as well

app/ghcup/BrickMain.hs

@@ -13,9 +13,9 @@ import           GHCup.Errors
 import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.Prelude ( decUTF8Safe )
+import           GHCup.Utils.Prelude ( decUTF8Safe )
-import           GHCup.System.Process
+import           GHCup.Utils.File
 
 import           Brick
 import           Brick.Widgets.Border

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,9 +12,9 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -34,8 +34,8 @@ import GHCup.Types.Optics
 import GHCup.Utils
 import Data.Versions
 import URI.ByteString (serializeURIRef')
-import GHCup.Prelude
+import GHCup.Utils.Prelude
-import GHCup.System.Process (exec)
+import GHCup.Utils.File (exec)
 import Data.Char (toLower)
 
 

app/ghcup/GHCup/OptParse/Common.hs

@@ -14,9 +14,9 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.MegaParsec
+import           GHCup.Utils.MegaParsec
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
@@ -89,6 +89,18 @@ toolVersionArgument criteria tool =
   mv _          = "VERSION|TAG"
 
 
+toolVersionOption :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
+toolVersionOption criteria tool =
+  option (eitherReader toolVersionEither)
+    (  sh tool
+    <> completer (tagCompleter (fromMaybe GHC tool) [])
+    <> foldMap (completer . versionCompleter criteria) tool)
+ where
+  sh (Just GHC) = long "ghc" <> metavar "GHC_VERSION|TAG"
+  sh (Just HLS) = long "hls" <> metavar "HLS_VERSION|TAG"
+  sh _          = long "version" <> metavar "VERSION|TAG"
+
+
 versionParser :: Parser GHCTargetVersion
 versionParser = option
   (eitherReader tVersionEither)
@@ -196,8 +208,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
     ]
 
 
-bindistParser :: String -> Either String URI
+uriParser :: String -> Either String URI
-bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
+uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
 
 
 absolutePathParser :: FilePath -> Either String FilePath
@@ -246,18 +258,6 @@ criteriaParser s' | t == T.pack "installed" = Right ListInstalled
   where t = T.toLower (T.pack s')
 
 
-toolVersionParser :: Parser ToolVersion
-toolVersionParser = verP' <|> toolP
- where
-  verP' = ToolVersion <$> versionParser
-  toolP =
-    ToolTag
-      <$> option
-            (eitherReader tagEither)
-            (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
-
-
-
 
 keepOnParser :: String -> Either String KeepDirs
 keepOnParser s' | t == T.pack "always" = Right Always
@@ -472,42 +472,22 @@ checkForUpdates :: ( MonadReader env m
                    , MonadIO m
                    , MonadFail m
                    )
-                => m ()
+                => m [(Tool, Version)]
 checkForUpdates = do
   GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
   lInstalled <- listVersions Nothing (Just ListInstalled)
   let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
 
-  forM_ (getLatest dls GHCup) $ \(l, _) -> do
+  ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do
-    (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
+    (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
-    when (l > ghc_ver)
+    if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing
-      $ logWarn $
-          "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
 
-  forM_ (getLatest dls GHC) $ \(l, _) -> do
+  otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
-    let mghc_ver = latestInstalled GHC
+    forMM (getLatest dls t) $ \(l, _) -> do
-    forM mghc_ver $ \ghc_ver ->
+      let mver = latestInstalled t
-      when (l > ghc_ver)
+      forMM mver $ \ver ->
-        $ logWarn $
+        if (l > ver) then pure $ Just (t, l) else pure Nothing
-          "New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
 
-  forM_ (getLatest dls Cabal) $ \(l, _) -> do
+  pure $ catMaybes (ghcup:otherTools)
-    let mcabal_ver = latestInstalled Cabal
+ where
-    forM mcabal_ver $ \cabal_ver ->
+  forMM a f = fmap join $ forM a f
-      when (l > cabal_ver)
-        $ logWarn $
-          "New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
-
-  forM_ (getLatest dls HLS) $ \(l, _) -> do
-    let mhls_ver = latestInstalled HLS
-    forM mhls_ver $ \hls_ver ->
-      when (l > hls_ver)
-        $ logWarn $
-          "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
-
-  forM_ (getLatest dls Stack) $ \(l, _) -> do
-    let mstack_ver = latestInstalled Stack
-    forM mstack_ver $ \stack_ver ->
-      when (l > stack_ver)
-        $ logWarn $
-          "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

app/ghcup/GHCup/OptParse/Compile.hs

@@ -13,13 +13,13 @@ module GHCup.OptParse.Compile where
 
 import           GHCup
 import           GHCup.Errors
+import           GHCup.Utils.File
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
-import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -40,6 +40,7 @@ import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
+import           URI.ByteString          hiding ( uriParser )
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
 import System.FilePath (isPathSeparator)
@@ -68,7 +69,7 @@ data GHCCompileOptions = GHCCompileOptions
   , bootstrapGhc :: Either Version FilePath
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe FilePath
-  , patchDir     :: Maybe FilePath
+  , patches      :: Maybe (Either FilePath [URI])
   , crossTarget  :: Maybe Text
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
@@ -84,10 +85,11 @@ data HLSCompileOptions = HLSCompileOptions
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
   , isolateDir   :: Maybe FilePath
-  , cabalProject :: Maybe FilePath
+  , cabalProject :: Maybe (Either FilePath URI)
-  , cabalProjectLocal :: Maybe FilePath
+  , cabalProjectLocal :: Maybe URI
-  , patchDir     :: Maybe FilePath
+  , patches      :: Maybe (Either FilePath [URI])
   , targetGHCs   :: [ToolVersion]
+  , cabalArgs    :: [Text]
   }
 
 
@@ -148,7 +150,10 @@ Examples:
   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|]
+  # compile 1.4.0 for ghc 8.10.5 and 8.10.7
+  ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
+  # compile from master for ghc 8.10.7, linking everything dynamically
+  ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
 
 
 ghcCompileOpts :: Parser GHCCompileOptions
@@ -195,13 +200,23 @@ ghcCompileOpts =
               "Absolute path to build config file"
             )
           )
-    <*> optional
+    <*> (optional
-          (option
+          (
-            str
+            (fmap Right $ many $ option
-            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              (eitherReader uriParser)
-              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              (long "patch" <> metavar "PATCH_URI" <> help
+                "URI to a patch (https/http/file)"
+              )
+            )
+            <|>
+            (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)"
+              )
             )
           )
+        )
     <*> optional
           (option
             str
@@ -296,26 +311,37 @@ hlsCompileOpts =
            )
     <*> optional
           (option
-            str
+            ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
             (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
-              "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
+              "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."
             )
           )
     <*> optional
           (option
-            (eitherReader absolutePathParser)
+            (eitherReader uriParser)
             (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."
+              "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
             )
           )
-    <*> optional
+    <*> (optional
-          (option
+          (
-            (eitherReader absolutePathParser)
+            (fmap Right $ many $ option
-            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              (eitherReader uriParser)
-              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              (long "patch" <> metavar "PATCH_URI" <> help
+                "URI to a patch (https/http/file)"
+              )
+            )
+            <|>
+            (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)"
+              )
             )
           )
-    <*> some (toolVersionArgument Nothing (Just GHC))
+        )
+    <*> some (toolVersionOption Nothing (Just GHC))
+    <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
 
 
 
@@ -403,11 +429,11 @@ compile :: ( Monad 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 runAppState runLogger = do
+compile compileCommand settings Dirs{..} runAppState runLogger = do
-  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
   case compileCommand of
     (CompileHLS HLSCompileOptions { .. }) -> do
       runCompileHLS runAppState (do
@@ -430,7 +456,8 @@ compile compileCommand settings runAppState runLogger = do
                     isolateDir
                     cabalProject
                     cabalProjectLocal
-                    patchDir
+                    patches
+                    cabalArgs
         GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
         let vi = getVersionInfo targetVer HLS dls
         when setCompile $ void $ liftE $
@@ -477,7 +504,7 @@ compile compileCommand settings runAppState runLogger = do
                     bootstrapGhc
                     jobs
                     buildConfig
-                    patchDir
+                    patches
                     addConfArgs
                     buildFlavour
                     hadrian

app/ghcup/GHCup/OptParse/Config.hs

@@ -14,9 +14,9 @@ module GHCup.OptParse.Config where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -17,10 +17,9 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Version
 import           GHCup.Types
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
-import           GHCup.Directories
+import           GHCup.Utils.Dirs
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -37,6 +36,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
+import GHCup.Utils.File
 import Language.Haskell.TH
 
 

app/ghcup/GHCup/OptParse/GC.hs

@@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Install.hs

@@ -17,9 +17,9 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.File
-import           GHCup.QQ.String
+import           GHCup.Utils.Logger
-import           GHCup.System.Process
+import           GHCup.Utils.String.QQ
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)
@@ -37,7 +37,7 @@ import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-import           URI.ByteString
+import           URI.ByteString          hiding ( uriParser )
 
 import qualified Data.Text                     as T
 
@@ -187,7 +187,7 @@ installOpts tool =
     <*> (   (   (,)
             <$> optional
                   (option
-                    (eitherReader bindistParser)
+                    (eitherReader uriParser)
                     (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
                       "Install the specified version from this bindist"
                     )

app/ghcup/GHCup/OptParse/List.hs

@@ -11,7 +11,7 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -14,9 +14,9 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -33,7 +33,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Prelude
+import GHCup.Utils.Prelude
 import GHCup.Download (getDownloadsF)
 
 

app/ghcup/GHCup/OptParse/Rm.hs

@@ -18,9 +18,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Set.hs

@@ -17,8 +17,8 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -10,7 +10,7 @@ module GHCup.OptParse.ToolRequirements where
 
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -28,7 +28,7 @@ import qualified Data.Text.IO                  as T
 import Control.Exception.Safe (MonadMask)
 import GHCup.Types.Optics
 import GHCup.Platform
-import GHCup.Prelude
+import GHCup.Utils.Prelude
 import GHCup.Requirements
 import System.IO
 

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -14,7 +14,7 @@ module GHCup.OptParse.Upgrade where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -113,17 +113,17 @@ runUpgrade runAppState =
 
 
 upgrade :: ( Monad m
-         , MonadMask m
+           , MonadMask m
-         , MonadUnliftIO m
+           , MonadUnliftIO m
-         , MonadFail m
+           , MonadFail m
-         )
+           )
         => UpgradeOpts
         -> Bool
+        -> Dirs
         -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
         -> (ReaderT LeanAppState m () -> m ())
         -> m ExitCode
-upgrade uOpts force' runAppState runLogger = do
+upgrade uOpts force' Dirs{..} runAppState runLogger = do
-  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
   target <- case uOpts of
     UpgradeInplace  -> Just <$> liftIO getExecutablePath
     (UpgradeAt p)   -> pure $ Just p

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -17,8 +17,8 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Types
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/Main.hs

@@ -20,10 +20,11 @@ import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Platform
 import           GHCup.Types
+import           GHCup.Types.Optics      hiding ( toolRequirements )
 import           GHCup.Utils
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 import           GHCup.Version
 
 import           Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -39,6 +40,7 @@ import           Data.Aeson.Encode.Pretty       ( encodePretty )
 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
@@ -191,7 +193,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           -------------------------
 
 
-              appState = do
+          let appState = do
                 pfreq <- (
                   runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
                   ) >>= \case
@@ -227,8 +229,28 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 #if defined(BRICK)
                   Interactive -> pure ()
 #endif
+                  -- check for new tools
                   _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                         Nothing -> runReaderT checkForUpdates s'
+                         Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
+                           newTools <- lift checkForUpdates 
+                           forM_ newTools $ \newTool@(t, l) -> do
+                             -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
+                             alreadyInstalling' <- alreadyInstalling optCommand newTool
+                             when (not alreadyInstalling') $
+                               case t of
+                                 GHCup -> runLogger $
+                                            logWarn ("New GHCup version available: "
+                                              <> prettyVer l
+                                              <> ". To upgrade, run 'ghcup upgrade'")
+                                 _ -> runLogger $
+                                        logWarn ("New "
+                                          <> T.pack (prettyShow t)
+                                          <> " version available. "
+                                          <> "To upgrade, run 'ghcup install "
+                                          <> T.pack (prettyShow t)
+                                          <> " "
+                                          <> prettyVer l
+                                          <> "'")
                          Just _ -> pure ()
 
                 -- TODO: always run for windows
@@ -270,11 +292,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             List lo                  -> list lo no_color runAppState
             Rm rmCommand             -> rm rmCommand runAppState runLogger
             DInfo                    -> dinfo runAppState runLogger
-            Compile compileCommand   -> compile compileCommand settings runAppState runLogger
+            Compile compileCommand   -> compile compileCommand settings dirs runAppState runLogger
             Config configCommand     -> config configCommand settings keybindings runLogger
             Whereis whereisOptions
                     whereisCommand   -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
-            Upgrade uOpts force'     -> upgrade uOpts force' runAppState runLogger
+            Upgrade uOpts force'     -> upgrade uOpts force' dirs runAppState runLogger
             ToolRequirements         -> toolRequirements runAppState runLogger
             ChangeLog changelogOpts  -> changelog changelogOpts runAppState runLogger
             Nuke                     -> nuke appState runLogger
@@ -287,4 +309,56 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
   pure ()
 
+ where
+  alreadyInstalling :: ( HasLog env
+                       , MonadFail m
+                       , MonadReader env m
+                       , HasGHCupInfo env
+                       , HasDirs env
+                       , MonadThrow m
+                       , MonadIO m
+                       , MonadCatch m
+                       )
+                    => Command
+                    -> (Tool, Version)
+                    -> Excepts
+                         '[ TagNotFound
+                          , NextVerNotFound
+                          , NoToolVersionSet
+                          ] 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 (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
+    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
+  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
+    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
+    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
+    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
+  alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True
+  alreadyInstalling _ _ = pure False
 
+  cmp' :: ( HasLog env
+          , MonadFail m
+          , MonadReader env m
+          , HasGHCupInfo env
+          , HasDirs env
+          , MonadThrow m
+          , MonadIO m
+          , MonadCatch m
+          )
+       => Tool
+       -> Maybe ToolVersion
+       -> Version
+       -> Excepts
+            '[ TagNotFound
+             , NextVerNotFound
+             , NoToolVersionSet
+             ] m Bool
+  cmp' tool instVer ver = do
+    (v, _) <- liftE $ fromVersion instVer tool
+    pure (v == mkTVer ver)

cabal.ghc8107.project.freeze

@@ -4,6 +4,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.HUnit ==1.6.2.0,
              any.HsOpenSSL ==0.11.7.2,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
+             any.OneTuple ==0.3.1,
              any.QuickCheck ==2.14.2,
              QuickCheck -old-random +templatehaskell,
              any.StateVar ==1.2.2,
@@ -28,10 +29,10 @@ constraints: any.Cabal ==3.6.2.0,
              any.attoparsec ==0.13.2.5,
              attoparsec -developer,
              any.base ==4.14.3.0,
-             any.base-compat ==0.12.0,
+             any.base-compat ==0.12.1,
-             any.base-compat-batteries ==0.12.0,
+             any.base-compat-batteries ==0.12.1,
-             any.base-orphans ==0.8.5,
+             any.base-orphans ==0.8.6,
-             any.base16-bytestring ==1.0.1.0,
+             any.base16-bytestring ==1.0.2.0,
              any.base64-bytestring ==1.1.0.0,
              any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
@@ -87,13 +88,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.ghc-byteorder ==4.11.0.0.10,
              any.ghc-prim ==0.6.1,
              any.happy ==1.20.0,
-             any.hashable ==1.3.4.1,
+             any.hashable ==1.3.5.0,
              hashable +integer-gmp -random-initial-seed,
              any.haskus-utils-data ==1.4,
              any.haskus-utils-types ==1.5.1,
-             any.haskus-utils-variant ==3.1,
+             any.haskus-utils-variant ==3.2.1,
              any.heaps ==0.4,
-             any.hsc2hs ==0.68.7,
+             any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
              any.hspec ==2.7.10,
              any.hspec-core ==2.7.10,
@@ -103,8 +104,8 @@ constraints: any.Cabal ==3.6.2.0,
              any.http-io-streams ==0.1.6.0,
              http-io-streams -brotli +fast-xor,
              any.indexed-profunctors ==0.1.1,
-             any.indexed-traversable ==0.1.1,
+             any.indexed-traversable ==0.1.2,
-             any.indexed-traversable-instances ==0.1,
+             any.indexed-traversable-instances ==0.1.1,
              any.integer-gmp ==1.0.3.0,
              any.integer-logarithms ==1.0.3.1,
              integer-logarithms -check-bounds +integer-gmp,
@@ -145,13 +146,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.polyparse ==1.13,
              any.pretty ==1.1.3.6,
              any.pretty-terminal ==0.1.0.0,
-             any.primitive ==0.7.2.0,
+             any.primitive ==0.7.3.0,
              any.process ==1.6.13.2,
              any.profunctors ==5.6.2,
              any.quickcheck-arbitrary-adt ==0.3.1.0,
              any.quickcheck-io ==0.2.0,
              any.random ==1.2.1,
-             any.recursion-schemes ==5.2.2.1,
+             any.recursion-schemes ==5.2.2.2,
              recursion-schemes +template-haskell,
              any.regex-base ==0.94.0.1,
              any.regex-posix ==0.96.0.1,
@@ -164,13 +165,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.safe-exceptions ==0.1.7.2,
              any.scientific ==0.3.7.0,
              scientific -bytestring-builder -integer-simple,
-             any.semialign ==1.2,
+             any.semialign ==1.2.0.1,
              semialign +semigroupoids,
              any.semigroupoids ==5.3.6,
              semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
              any.setenv ==0.1.1.3,
              any.split ==0.2.3.4,
-             any.splitmix ==0.1.0.3,
+             any.splitmix ==0.1.0.4,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.1,
              any.streamly ==0.8.0,
@@ -200,14 +201,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.6,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.7,
+             any.transformers-compat ==0.7.1,
              transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
              any.unix ==2.7.2.2,
-             any.unix-bytestring ==0.3.7.5,
+             any.unix-bytestring ==0.3.7.6,
              any.unix-compat ==0.5.3,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.14.0,
+             any.unordered-containers ==0.2.15.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -226,4 +227,4 @@ constraints: any.Cabal ==3.6.2.0,
              any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2021-10-24T10:21:56Z
+index-state: hackage.haskell.org 2021-11-12T11:11:19Z

cabal.ghc901.project.freeze

@@ -4,6 +4,7 @@ constraints: any.Cabal ==3.6.2.0,
              any.HUnit ==1.6.2.0,
              any.HsOpenSSL ==0.11.7.2,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
+             any.OneTuple ==0.3.1,
              any.QuickCheck ==2.14.2,
              QuickCheck -old-random +templatehaskell,
              any.StateVar ==1.2.2,
@@ -28,10 +29,10 @@ constraints: any.Cabal ==3.6.2.0,
              any.attoparsec ==0.13.2.5,
              attoparsec -developer,
              any.base ==4.15.0.0,
-             any.base-compat ==0.12.0,
+             any.base-compat ==0.12.1,
-             any.base-compat-batteries ==0.12.0,
+             any.base-compat-batteries ==0.12.1,
-             any.base-orphans ==0.8.5,
+             any.base-orphans ==0.8.6,
-             any.base16-bytestring ==1.0.1.0,
+             any.base16-bytestring ==1.0.2.0,
              any.base64-bytestring ==1.1.0.0,
              any.bifunctors ==5.5.11,
              bifunctors +semigroups +tagged,
@@ -88,13 +89,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.ghc-byteorder ==4.11.0.0.10,
              any.ghc-prim ==0.7.0,
              any.happy ==1.20.0,
-             any.hashable ==1.3.4.1,
+             any.hashable ==1.3.5.0,
              hashable +integer-gmp -random-initial-seed,
              any.haskus-utils-data ==1.4,
              any.haskus-utils-types ==1.5.1,
-             any.haskus-utils-variant ==3.1,
+             any.haskus-utils-variant ==3.2.1,
              any.heaps ==0.4,
-             any.hsc2hs ==0.68.7,
+             any.hsc2hs ==0.68.8,
              hsc2hs -in-ghc-tree,
              any.hspec ==2.7.10,
              any.hspec-core ==2.7.10,
@@ -104,8 +105,8 @@ constraints: any.Cabal ==3.6.2.0,
              any.http-io-streams ==0.1.6.0,
              http-io-streams -brotli +fast-xor,
              any.indexed-profunctors ==0.1.1,
-             any.indexed-traversable ==0.1.1,
+             any.indexed-traversable ==0.1.2,
-             any.indexed-traversable-instances ==0.1,
+             any.indexed-traversable-instances ==0.1.1,
              any.integer-logarithms ==1.0.3.1,
              integer-logarithms -check-bounds +integer-gmp,
              any.io-streams ==1.5.2.1,
@@ -145,13 +146,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.polyparse ==1.13,
              any.pretty ==1.1.3.6,
              any.pretty-terminal ==0.1.0.0,
-             any.primitive ==0.7.2.0,
+             any.primitive ==0.7.3.0,
              any.process ==1.6.11.0,
              any.profunctors ==5.6.2,
              any.quickcheck-arbitrary-adt ==0.3.1.0,
              any.quickcheck-io ==0.2.0,
              any.random ==1.2.1,
-             any.recursion-schemes ==5.2.2.1,
+             any.recursion-schemes ==5.2.2.2,
              recursion-schemes +template-haskell,
              any.regex-base ==0.94.0.1,
              any.regex-posix ==0.96.0.1,
@@ -164,13 +165,13 @@ constraints: any.Cabal ==3.6.2.0,
              any.safe-exceptions ==0.1.7.2,
              any.scientific ==0.3.7.0,
              scientific -bytestring-builder -integer-simple,
-             any.semialign ==1.2,
+             any.semialign ==1.2.0.1,
              semialign +semigroupoids,
              any.semigroupoids ==5.3.6,
              semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
              any.setenv ==0.1.1.3,
              any.split ==0.2.3.4,
-             any.splitmix ==0.1.0.3,
+             any.splitmix ==0.1.0.4,
              splitmix -optimised-mixer,
              any.stm ==2.5.0.0,
              any.streamly ==0.8.0,
@@ -200,14 +201,14 @@ constraints: any.Cabal ==3.6.2.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.6,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.7,
+             any.transformers-compat ==0.7.1,
              transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
              any.unix ==2.7.2.2,
-             any.unix-bytestring ==0.3.7.5,
+             any.unix-bytestring ==0.3.7.6,
              any.unix-compat ==0.5.3,
              unix-compat -old-time,
              any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.14.0,
+             any.unordered-containers ==0.2.15.0,
              unordered-containers -debug,
              any.uri-bytestring ==0.3.3.1,
              uri-bytestring -lib-werror,
@@ -226,4 +227,4 @@ constraints: any.Cabal ==3.6.2.0,
              any.zlib ==0.6.2.3,
              zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
              any.zlib-bindings ==0.1.1.5
-index-state: hackage.haskell.org 2021-10-24T10:21:56Z
+index-state: hackage.haskell.org 2021-11-12T11:11:19Z

cabal.project

@@ -8,15 +8,15 @@ package ghcup
     tests: True
     flags: +tui
 
+source-repository-package
+  type: git
+  location: https://github.com/bgamari/terminal-size.git
+  tag: 34ea816bd63f75f800eedac12c6908c6f3736036
+
 constraints: http-io-streams -brotli,
              any.Cabal ==3.6.2.0,
              any.aeson >= 2.0.1.0
 
-source-repository-package
-  type: git
-  location: https://github.com/input-output-hk/optparse-applicative
-  tag: 7497a29cb998721a9068d5725d49461f2bba0e7a
-
 package libarchive
   flags: -system-libarchive
 

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.17.3
+version:            0.1.17.4
 license:            LGPL-3.0-only
 license-file:       LICENSE
 copyright:          Julian Ospald 2020
@@ -51,16 +51,8 @@ flag no-exe
 library
   exposed-modules:
     GHCup
-    GHCup.Data.Versions
-    GHCup.GHC
-    GHCup.GHC.Rm
-    GHCup.GHC.Unset
-    GHCup.GHC.Set
-    GHCup.GHC.Compile
-    GHCup.GHC.Common
-    GHCup.GHC.Install
     GHCup.Download
-    GHCup.Download.Common
+    GHCup.Download.Utils
     GHCup.Errors
     GHCup.Platform
     GHCup.Requirements
@@ -68,16 +60,14 @@ library
     GHCup.Types.JSON
     GHCup.Types.Optics
     GHCup.Utils
-    GHCup.Directories
+    GHCup.Utils.Dirs
-    GHCup.System.Process
+    GHCup.Utils.File
-    GHCup.System.Directory
+    GHCup.Utils.File.Common
-    GHCup.System.Process.Common
+    GHCup.Utils.Logger
-    GHCup.System.Console
+    GHCup.Utils.MegaParsec
-    GHCup.Logger
+    GHCup.Utils.Prelude
-    GHCup.MegaParsec
+    GHCup.Utils.String.QQ
-    GHCup.Prelude
+    GHCup.Utils.Version.QQ
-    GHCup.QQ.String
-    GHCup.QQ.Version
     GHCup.Version
 
   hs-source-dirs:     lib
@@ -120,7 +110,7 @@ library
     , disk-free-space       ^>=0.1.0.1
     , filepath              ^>=1.4.2.1
     , haskus-utils-types    ^>=1.5
-    , haskus-utils-variant  >=3.0        && <3.2
+    , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , lzma-static           ^>=5.2.5.3
     , megaparsec            >=8.0.0      && <9.1
@@ -162,9 +152,9 @@ library
   if os(windows)
     cpp-options:   -DIS_WINDOWS
     other-modules:
-      GHCup.System.Process.Windows
+      GHCup.Utils.File.Windows
-      GHCup.Prelude.Windows
+      GHCup.Utils.Prelude.Windows
-      GHCup.System.Console.Windows
+      GHCup.Utils.Windows
 
     build-depends:
       , bzlib
@@ -173,14 +163,13 @@ library
 
   else
     other-modules:
-      GHCup.System.Process.Posix
+      GHCup.Utils.File.Posix
-      GHCup.System.Console.Posix
+      GHCup.Utils.Posix
-      GHCup.Prelude.Posix
+      GHCup.Utils.Prelude.Posix
-      System.Console.Terminal.Common
-      System.Console.Terminal.Posix
 
     build-depends:
       , bz2              >=0.5.0.5 && <1.1
+      , terminal-size    ^>=0.3.2.1
       , unix             ^>=2.7
       , unix-bytestring  ^>=0.3.7.3
 
@@ -237,11 +226,11 @@ executable ghcup
     , directory             ^>=1.3.6.0
     , filepath              ^>=1.4.2.1
     , ghcup
-    , haskus-utils-variant  >=3.0      && <3.2
+    , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , megaparsec            >=8.0.0    && <9.1
     , mtl                   ^>=2.2
-    , optparse-applicative-fork  >=0.15.1.0 && <0.17
+    , optparse-applicative  >=0.15.1.0 && <0.17
     , pretty                ^>=1.1.3.1
     , pretty-terminal       ^>=0.1.0.0
     , resourcet             ^>=1.2.2

lib/GHCup/Download.hs

@@ -27,16 +27,16 @@ module GHCup.Download where
 
 #if defined(INTERNAL_DOWNLOADER)
 import           GHCup.Download.IOStreams
-import           GHCup.Download.Common
+import           GHCup.Download.Utils
 #endif
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Directories
+import           GHCup.Utils.Dirs
-import           GHCup.System.Process
+import           GHCup.Utils.File
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 import           GHCup.Version
 
 import           Control.Applicative

lib/GHCup/Download/IOStreams.hs

@@ -7,10 +7,10 @@
 module GHCup.Download.IOStreams where
 
 
-import           GHCup.Download.Common
+import           GHCup.Download.Utils
 import           GHCup.Errors
 import           GHCup.Types.JSON               ( )
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Applicative
 import           Control.Exception.Safe

lib/GHCup/Download/Utils.hs

@@ -4,13 +4,13 @@
 {-# LANGUAGE TypeFamilies          #-}
 
 
-module GHCup.Download.Common where
+module GHCup.Download.Utils where
 
 
 import           GHCup.Errors
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Applicative
 import           Control.Monad

lib/GHCup/Platform.hs

@@ -23,10 +23,10 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.System.Process
+import           GHCup.Utils.File
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

lib/GHCup/System/Console.hs

@@ -1,16 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module GHCup.System.Console (
-#if IS_WINDOWS
-  module GHCup.System.Console.Windows
-#else
-  module GHCup.System.Console.Posix
-#endif
-) where
-
-
-#if IS_WINDOWS
-import GHCup.System.Console.Windows
-#else
-import GHCup.System.Console.Posix
-#endif

lib/GHCup/System/Process.hs

@@ -1,19 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module GHCup.System.Process (
-  module GHCup.System.Process.Common,
-#if IS_WINDOWS
-  module GHCup.System.Process.Windows
-#else
-  module GHCup.System.Process.Posix
-#endif
-) where
-
-
-#if IS_WINDOWS
-import GHCup.System.Process.Windows
-#else
-import GHCup.System.Process.Posix
-#endif
-
-import GHCup.System.Process.Common

lib/GHCup/System/Process/Common.hs

@@ -1,37 +0,0 @@
-{-# LANGUAGE TemplateHaskell  #-}
-
-module GHCup.System.Process.Common where
-
-
-import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
-
-import qualified Data.ByteString.Lazy          as BL
-
-
-
-data ProcessError = NonZeroExit Int FilePath [String]
-                  | PTerminated FilePath [String]
-                  | PStopped FilePath [String]
-                  | NoSuchPid FilePath [String]
-                  deriving Show
-
-instance Pretty ProcessError where
-  pPrint (NonZeroExit e exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
-  pPrint (PTerminated exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
-  pPrint (PStopped exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
-  pPrint (NoSuchPid exe args) =
-    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
-
-data CapturedProcess = CapturedProcess
-  { _exitCode :: ExitCode
-  , _stdOut   :: BL.ByteString
-  , _stdErr   :: BL.ByteString
-  }
-  deriving (Eq, Show)
-
-makeLenses ''CapturedProcess

lib/GHCup/Types/JSON.hs

@@ -22,9 +22,9 @@ Portability : portable
 module GHCup.Types.JSON where
 
 import           GHCup.Types
-import           GHCup.MegaParsec
+import           GHCup.Utils.MegaParsec
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
-import           GHCup.Logger             () -- TH is broken shite and needs GHCup.Logger for linking, although we don't depend on the file.
+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            ( (<|>) )

lib/GHCup/Utils.hs

@@ -20,37 +20,33 @@ This module contains GHCup helpers specific to
 installation and introspection of files/versions etc.
 -}
 module GHCup.Utils
-  ( module GHCup.Directories
+  ( module GHCup.Utils.Dirs
   , module GHCup.Utils
 #if defined(IS_WINDOWS)
-  , module GHCup.System.Console.Windows
+  , module GHCup.Utils.Windows
 #else
-  , module GHCup.System.Console.Posix
+  , module GHCup.Utils.Posix
 #endif
   )
 where
 
 
 #if defined(IS_WINDOWS)
-import GHCup.System.Console.Windows
+import GHCup.Utils.Windows
 #else
-import GHCup.System.Console.Posix
+import GHCup.Utils.Posix
 #endif
-import {-# SOURCE #-} GHCup.GHC.Common
-import {-# SOURCE #-} GHCup.GHC.Set
-import           GHCup.Data.Versions
 import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Directories
+import           GHCup.Utils.Dirs
-import           GHCup.Logger
+import           GHCup.Utils.File
-import           GHCup.MegaParsec
+import           GHCup.Utils.Logger
-import           GHCup.Prelude
+import           GHCup.Utils.MegaParsec
-import           GHCup.QQ.String
+import           GHCup.Utils.Prelude
-import           GHCup.System.Directory
+import           GHCup.Utils.String.QQ
-import           GHCup.System.Process
 
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
@@ -71,7 +67,7 @@ import           Data.List
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.Maybe
 import           Data.Text                      ( Text )
-import           Data.Versions
+import           Data.Versions         hiding   ( patch )
 import           GHC.IO.Exception
 import           Haskus.Utils.Variant.Excepts
 import           Optics
@@ -81,7 +77,6 @@ import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
 import           URI.ByteString
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Codec.Compression.BZip        as BZip
 import qualified Codec.Compression.GZip        as GZip
@@ -102,14 +97,14 @@ import qualified Data.List.NonEmpty            as NE
 -- >>> import System.Directory
 -- >>> import URI.ByteString
 -- >>> import qualified Data.Text as T
--- >>> import GHCup.Prelude
+-- >>> import GHCup.Utils.Prelude
 -- >>> import GHCup.Download
 -- >>> import GHCup.Version
 -- >>> import GHCup.Errors
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
 -- >>> import Optics
--- >>> import GHCup.QQ.Version
+-- >>> import GHCup.Utils.Version.QQ
 -- >>> import qualified Data.Text.Encoding as E
 -- >>> import Control.Monad.Reader
 -- >>> import Haskus.Utils.Variant.Excepts
@@ -125,6 +120,161 @@ import qualified Data.List.NonEmpty            as NE
 
 
 
+    ------------------------
+    --[ Symlink handling ]--
+    ------------------------
+
+
+-- | The symlink destination of a ghc tool.
+ghcLinkDestination :: ( MonadReader env m
+                      , HasDirs env
+                      , MonadThrow m, MonadIO m)
+                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
+                   -> GHCTargetVersion
+                   -> m FilePath
+ghcLinkDestination tool ver = do
+  Dirs {..}  <- getDirs
+  ghcd <- ghcupGHCDir ver
+  pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
+
+
+-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
+rmMinorSymlinks :: ( MonadReader env m
+                   , HasDirs env
+                   , MonadIO m
+                   , HasLog env
+                   , MonadThrow m
+                   , MonadFail m
+                   , MonadMask m
+                   )
+                => GHCTargetVersion
+                -> Excepts '[NotInstalled] m ()
+rmMinorSymlinks tv@GHCTargetVersion{..} = do
+  Dirs {..}  <- lift getDirs
+
+  files                         <- liftE $ ghcToolFiles tv
+  forM_ files $ \f -> do
+    let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
+    let fullF = binDir </> f_xyz
+    lift $ logDebug ("rm -f " <> T.pack fullF)
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
+
+
+-- | Removes the set ghc version for the given target, if any.
+rmPlain :: ( MonadReader env m
+           , HasDirs env
+           , HasLog env
+           , MonadThrow m
+           , MonadFail m
+           , MonadIO m
+           , MonadMask m
+           )
+        => Maybe Text -- ^ target
+        -> Excepts '[NotInstalled] m ()
+rmPlain target = do
+  Dirs {..}  <- lift getDirs
+  mtv                           <- lift $ ghcSet target
+  forM_ mtv $ \tv -> do
+    files <- liftE $ ghcToolFiles tv
+    forM_ files $ \f -> do
+      let fullF = binDir </> f <> exeExt
+      lift $ logDebug ("rm -f " <> T.pack fullF)
+      lift $ hideError doesNotExistErrorType $ rmLink fullF
+    -- old ghcup
+    let hdc_file = binDir </> "haddock-ghc" <> exeExt
+    lift $ logDebug ("rm -f " <> T.pack hdc_file)
+    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
+
+
+-- | Remove the major GHC symlink, e.g. ghc-8.6.
+rmMajorSymlinks :: ( MonadReader env m
+                   , HasDirs env
+                   , MonadIO m
+                   , HasLog env
+                   , MonadThrow m
+                   , MonadFail m
+                   , MonadMask m
+                   )
+                => GHCTargetVersion
+                -> Excepts '[NotInstalled] m ()
+rmMajorSymlinks tv@GHCTargetVersion{..} = do
+  Dirs {..}  <- lift getDirs
+  (mj, mi) <- getMajorMinorV _tvVersion
+  let v' = intToText mj <> "." <> intToText mi
+
+  files                         <- liftE $ ghcToolFiles tv
+  forM_ files $ \f -> do
+    let f_xy = f <> "-" <> T.unpack v' <> exeExt
+    let fullF = binDir </> f_xy
+    lift $ logDebug ("rm -f " <> T.pack fullF)
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
+
+
+
+
+    -----------------------------------
+    --[ Set/Installed introspection ]--
+    -----------------------------------
+
+
+-- | Whether the given GHC versin is installed.
+ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
+ghcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  liftIO $ doesDirectoryExist ghcdir
+
+
+-- | Whether the given GHC version is installed from source.
+ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
+ghcSrcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
+
+
+-- | Whether the given GHC version is set as the current.
+ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
+       => Maybe Text   -- ^ the target of the GHC version, if any
+                       --  (e.g. armv7-unknown-linux-gnueabihf)
+       -> m (Maybe GHCTargetVersion)
+ghcSet mtarget = do
+  Dirs {..}  <- getDirs
+  let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
+  let ghcBin = binDir </> ghc <> exeExt
+
+  -- link destination is of the form ../ghc/<ver>/bin/ghc
+  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
+  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
+    link <- liftIO $ getLinkTarget ghcBin
+    Just <$> ghcLinkVersion link
+ where
+  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
+  ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
+   where
+    parser =
+        (do
+           _    <- parseUntil1 ghcSubPath
+           _    <- ghcSubPath
+           r    <- parseUntil1 pathSep
+           rest <- MP.getInput
+           MP.setInput r
+           x <- ghcTargetVerP
+           MP.setInput rest
+           pure x
+         )
+        <* pathSep
+        <* MP.takeRest
+        <* MP.eof
+    ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
+
+-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
+-- If a dir cannot be parsed, returns left.
+getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
+getInstalledGHCs = do
+  ghcdir <- ghcupGHCBaseDir
+  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
+  forM fs $ \f -> case parseGHCupGHCDir f of
+    Right r -> pure $ Right r
+    Left  _ -> pure $ Left f
 
 
 -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
@@ -438,6 +588,79 @@ hlsSymlinks = do
 
 
 
+    -----------------------------------------
+    --[ Major version introspection (X.Y) ]--
+    -----------------------------------------
+
+
+-- | Extract (major, minor) from any version.
+getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
+getMajorMinorV Version {..} = case _vChunks of
+  ((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
+  _ -> throwM $ ParseError "Could not parse X.Y from version"
+
+
+matchMajor :: Version -> Int -> Int -> Bool
+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
+
+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_, rest) <- versionToPVP _tvVersion
+        pure (pvp_, rest, _tvTarget)
+
+  getGHCForPVP' pvpIn ghcs' mt
+
+-- | Like 'getGHCForPVP', except with explicit input parameter.
+--
+-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing
+-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}})
+-- >>> 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, Text, 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_, rest, target) -> do
+    ver' <- pvpToVersion pvp_ rest
+    pure (GHCTargetVersion target ver')
 
 
 -- | Get the latest available ghc for the given PVP version, which
@@ -587,6 +810,39 @@ getLatestBaseVersion av pvpVer =
     -------------
 
 
+-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
+-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
+--
+-- Returns unversioned relative files without extension, e.g.:
+--
+--   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
+ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
+             => GHCTargetVersion
+             -> Excepts '[NotInstalled] m [FilePath]
+ghcToolFiles ver = do
+  ghcdir <- lift $ ghcupGHCDir ver
+  let bindir = ghcdir </> "bin"
+
+  -- fail if ghc is not installed
+  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
+        (throwE (NotInstalled GHC ver))
+
+  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
+  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
+
+ where
+
+  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
+  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
+
+  getUniqueTools :: [[(FilePath, String)]] -> [String]
+  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
+
+  blackListedTools :: [String]
+  blackListedTools = ["haddock-ghc"]
+
+  isNotAnyInfix :: [String] -> String -> Bool
+  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
@@ -600,6 +856,7 @@ make :: ( MonadThrow m
         , MonadIO m
         , MonadReader env m
         , HasDirs env
+        , HasLog env
         , HasSettings env
         )
      => [String]
@@ -635,15 +892,22 @@ applyPatches pdir ddir = do
                      execBlank
                      ([s|.+\.(patch|diff)$|] :: ByteString)
       )
-  forM_ (sort patches) $ \patch' -> do
+  forM_ (sort patches) $ \patch' -> applyPatch patch' ddir
-    lift $ logInfo $ "Applying patch " <> T.pack patch'
+
-    fmap (either (const Nothing) Just)
+
-         (exec
+applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
-           "patch"
+           => FilePath   -- ^ Patch
-           ["-p1", "-i", patch']
+           -> FilePath   -- ^ dir to apply patches in
-           (Just ddir)
+           -> Excepts '[PatchFailed] m ()
-           Nothing)
+applyPatch patch ddir = do
-      !? PatchFailed
+  lift $ logInfo $ "Applying patch " <> T.pack patch
+  fmap (either (const Nothing) Just)
+       (exec
+         "patch"
+         ["-p1", "-s", "-f", "-i", patch]
+         (Just ddir)
+         Nothing)
+    !? PatchFailed
 
 
 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
@@ -877,41 +1141,11 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
 
 -- | For ghc without arch triple, this is:
 --
---    - ghc-<ver> (e.g. ghc-8.10.4)
+--    - ghc
 --
 -- For ghc with arch triple:
 --
---    - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)
+--    - <triple>-ghc (e.g. arm-linux-gnueabihf-ghc)
 ghcBinaryName :: GHCTargetVersion -> String
-ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
+ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)
-ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
+ghcBinaryName (GHCTargetVersion Nothing  _) = T.unpack ("ghc" <> T.pack exeExt)
-
-
-
--- | Warn if the installed and set HLS is not compatible with the installed and
--- set GHC version.
-warnAboutHlsCompatibility :: ( MonadReader env m
-                             , HasDirs env
-                             , HasLog env
-                             , MonadThrow m
-                             , MonadCatch m
-                             , MonadIO m
-                             )
-                          => m ()
-warnAboutHlsCompatibility = do
-  supportedGHC <- hlsGHCVersions
-  currentGHC   <- fmap _tvVersion <$> ghcSet Nothing
-  currentHLS   <- hlsSet
-
-  case (currentGHC, currentHLS) of
-    (Just gv, Just hv) | gv `notElem` supportedGHC -> do
-      logWarn $
-        "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
-        "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
-        "Haskell IDE support may not work until this is fixed." <> "\n" <>
-        "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
-        T.pack (prettyShow supportedGHC)
-        
-    _ -> return ()
-
-

lib/GHCup/Utils/Dirs.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE ViewPatterns          #-}
 
 {-|
-Module      : GHCup.Directories
+Module      : GHCup.Utils.Dirs
 Description : Definition of GHCup directories
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,7 +13,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Directories
+module GHCup.Utils.Dirs
   ( getAllDirs
   , ghcupBaseDir
   , ghcupConfigFile
@@ -35,9 +35,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
-import           GHCup.MegaParsec
+import           GHCup.Utils.MegaParsec
-import           GHCup.Logger
+import           GHCup.Utils.Logger
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Exception.Safe
 import           Control.Monad

lib/GHCup/Utils/File.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP #-}
+
+module GHCup.Utils.File (
+  module GHCup.Utils.File.Common,
+#if IS_WINDOWS
+  module GHCup.Utils.File.Windows
+#else
+  module GHCup.Utils.File.Posix
+#endif
+) where
+
+import GHCup.Utils.File.Common
+#if IS_WINDOWS
+import GHCup.Utils.File.Windows
+#else
+import GHCup.Utils.File.Posix
+#endif

lib/GHCup/Utils/File/Common.hs

@@ -3,24 +3,51 @@
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE ViewPatterns      #-}
 
-module GHCup.System.Directory where
+module GHCup.Utils.File.Common where
 
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Monad.Reader
 import           Data.Maybe
 import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
+import           Optics                  hiding ((<|), (|>))
 import           System.Directory
 import           System.FilePath
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
+import qualified Data.ByteString.Lazy          as BL
 import qualified Text.Megaparsec               as MP
 
 
 
+data ProcessError = NonZeroExit Int FilePath [String]
+                  | PTerminated FilePath [String]
+                  | PStopped FilePath [String]
+                  | NoSuchPid FilePath [String]
+                  deriving Show
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
+  pPrint (PTerminated exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
+  pPrint (PStopped exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
+  pPrint (NoSuchPid exe args) =
+    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: BL.ByteString
+  , _stdErr   :: BL.ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess
 
 
 

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

@@ -1,4 +1,4 @@
-module GHCup.System.Directory where
+module GHCup.Utils.File.Common where
 
 import           Text.Regex.Posix
 

lib/GHCup/Utils/File/Posix.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 
 {-|
-Module      : GHCup.System.Process.Posix
+Module      : GHCup.Utils.File.Posix
 Description : File and unix APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,13 +13,13 @@ Portability : POSIX
 This module handles file and executable handling.
 Some of these functions use sophisticated logging.
 -}
-module GHCup.System.Process.Posix where
+module GHCup.Utils.File.Posix where
 
-import           GHCup.Prelude
+import           GHCup.Utils.File.Common
-import           GHCup.Logger
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
-import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
@@ -35,7 +35,6 @@ import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
 import           GHC.IO.Exception
-import           System.Console.Terminal.Common
 import           System.IO.Error
 import           System.FilePath
 import           System.Directory
@@ -51,7 +50,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 System.Console.Terminal.Size  as TP
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified "unix-bytestring" System.Posix.IO.ByteString
@@ -73,6 +72,7 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
 
 execLogged :: ( MonadReader env m
               , HasSettings env
+              , HasLog env
               , HasDirs env
               , MonadIO m
               , MonadThrow m)
@@ -85,6 +85,7 @@ execLogged :: ( MonadReader env m
 execLogged exe args chdir lfile env = do
   Settings {..} <- getSettings
   Dirs {..} <- getDirs
+  logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
   let logfile = logsDir </> lfile <> ".log"
   liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
                    closeFd
@@ -180,7 +181,7 @@ execLogged exe args chdir lfile env = do
       modify (swapRegs bs')
       liftIO TP.size >>= \case
         Nothing -> pure ()
-        Just (Window _ w) -> do
+        Just (TP.Window _ w) -> do
           regs <- get
           liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
               BS.putStr

lib/GHCup/Utils/File/Windows.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 
 {-|
-Module      : GHCup.System.Process.Windows
+Module      : GHCup.Utils.File.Windows
 Description : File and windows APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,14 +13,14 @@ Portability : Windows
 This module handles file and executable handling.
 Some of these functions use sophisticated logging.
 -}
-module GHCup.System.Process.Windows where
+module GHCup.Utils.File.Windows where
 
 import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
-import           GHCup.Directories
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
-import           GHCup.System.Directory
-import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.DeepSeq
@@ -41,6 +41,7 @@ import qualified Control.Exception             as EX
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Map.Strict               as Map
+import qualified Data.Text                     as T
 
 
 
@@ -150,6 +151,7 @@ executeOut path args chdir = do
 
 execLogged :: ( MonadReader env m
               , HasDirs env
+              , HasLog env
               , HasSettings env
               , MonadIO m
               , MonadThrow m)
@@ -161,6 +163,7 @@ execLogged :: ( MonadReader env m
            -> m (Either ProcessError ())
 execLogged exe args chdir lfile env = do
   Dirs {..} <- getDirs
+  logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
   let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
       stderrLogfile = logsDir </> lfile <> ".stderr.log"
   cp <- createProcessWithMingwPath ((proc exe args)

lib/GHCup/Utils/Logger.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 
 {-|
-Module      : GHCup.Logger
+Module      : GHCup.Utils.Logger
 Description : logger definition
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -14,12 +14,12 @@ Portability : portable
 
 Here we define our main logger.
 -}
-module GHCup.Logger where
+module GHCup.Utils.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.System.Directory
+import {-# SOURCE #-} GHCup.Utils.File.Common
-import           GHCup.QQ.String
+import           GHCup.Utils.String.QQ
 
 import           Control.Exception.Safe
 import           Control.Monad
@@ -34,7 +34,7 @@ import           System.IO.Error
 import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
-import GHCup.Prelude
+import GHCup.Utils.Prelude
 import qualified Data.Text                     as T
 
 logInfo :: ( MonadReader env m

lib/GHCup/Utils/Logger.hs-boot

@@ -3,7 +3,7 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
-module GHCup.Logger where
+module GHCup.Utils.Logger where
 
 import           GHCup.Types
 

lib/GHCup/Utils/MegaParsec.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings    #-}
 
 {-|
-Module      : GHCup.MegaParsec
+Module      : GHCup.Utils.MegaParsec
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -10,7 +10,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.MegaParsec where
+module GHCup.Utils.MegaParsec where
 
 import           GHCup.Types
 

lib/GHCup/Utils/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.System.Console.Posix where
+module GHCup.Utils.Posix where
 
 
 -- | Enables ANSI support on windows, does nothing on unix.

lib/GHCup/Utils/Prelude.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeOperators       #-}
 
 {-|
-Module      : GHCup.Prelude
+Module      : GHCup.Utils.Prelude
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -17,12 +17,12 @@ Portability : portable
 
 GHCup specific prelude. Lots of Excepts functionality.
 -}
-module GHCup.Prelude
+module GHCup.Utils.Prelude
-  (module GHCup.Prelude,
+  (module GHCup.Utils.Prelude,
 #if defined(IS_WINDOWS)
-   module GHCup.Prelude.Windows
+   module GHCup.Utils.Prelude.Windows
 #else
-   module GHCup.Prelude.Posix
+   module GHCup.Utils.Prelude.Posix
 #endif
   )
 where
@@ -30,11 +30,11 @@ where
 import           GHCup.Types
 import           GHCup.Errors
 import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Logger
+import {-# SOURCE #-} GHCup.Utils.Logger
 #if defined(IS_WINDOWS)
-import           GHCup.Prelude.Windows
+import           GHCup.Utils.Prelude.Windows
 #else
-import           GHCup.Prelude.Posix
+import           GHCup.Utils.Prelude.Posix
 #endif
 
 import           Control.Applicative

lib/GHCup/Utils/Prelude/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.Prelude.Posix where
+module GHCup.Utils.Prelude.Posix where
 
 import System.Directory
 import System.Posix.Files

lib/GHCup/Utils/Prelude/Windows.hs

@@ -1,4 +1,4 @@
-module GHCup.Prelude.Windows where
+module GHCup.Utils.Prelude.Windows where
 
 import qualified System.Win32.File             as Win32
 

lib/GHCup/Utils/String/QQ.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 {-|
-Module      : GHCup.QQ.String
+Module      : GHCup.Utils.String.QQ
 Description : String quasi quoters
 Copyright   : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
 License     : LGPL-3.0
@@ -30,7 +30,7 @@ Any instance of the IsString type is permitted.
 (For GHC versions 6, write "[$s||]" instead of "[s||]".)
 
 -}
-module GHCup.QQ.String
+module GHCup.Utils.String.QQ
   ( s
   )
 where

lib/GHCup/Utils/Version/QQ.hs

@@ -8,7 +8,7 @@
 
 
 {-|
-Module      : GHCup.QQ.Version
+Module      : GHCup.Utils.Version.QQ
 Description : Version quasi-quoters
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -16,7 +16,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.QQ.Version where
+module GHCup.Utils.Version.QQ where
 
 import           Data.Data
 import           Data.Text                      ( Text )

lib/GHCup/Utils/Windows.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module GHCup.System.Console.Windows where
+module GHCup.Utils.Windows where
 
 
 import           Control.Exception.Safe

lib/System/Console/Terminal/Common.hs

@@ -1,43 +0,0 @@
-{-# 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

@@ -1,65 +0,0 @@
-{-# 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

@@ -25,7 +25,7 @@
 
 plat="$(uname -s)"
 arch=$(uname -m)
-ghver="0.1.17.3"
+ghver="0.1.17.4"
 base_url="https://downloads.haskell.org/~ghcup"
 
 export GHCUP_SKIP_UPDATE_CHECK=yes
@@ -39,7 +39,6 @@ case "${plat}" in
 			;;
 		*)
 			: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
-			export GHCUP_USE_XDG_DIRS
 
 			if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
 				GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
@@ -223,7 +222,8 @@ download_ghcup() {
             if freebsd-version | grep -E '^12.*' ; then
                 freebsd_ver=12
             elif freebsd-version | grep -E '^13.*' ; then
-                freebsd_ver=13
+                # TODO: missing FreeBSD13 version
+                freebsd_ver=12
             else
                 die "Unsupported FreeBSD version! Please report a bug at https://gitlab.haskell.org/haskell/ghcup-hs/-/issues"
             fi
@@ -237,10 +237,12 @@ download_ghcup() {
 				*) die "Unknown architecture: ${arch}"
 					;;
 			esac
-			_url=${base_url}/${ghver}/x86_64-portbld-freebsd${freebsd_ver}-ghcup-${ghver}
+			_url=${base_url}/${ghver}/x86_64-freebsd${freebsd_ver}-ghcup-${ghver}
             ;;
         "Darwin"|"darwin")
-			case "${arch}" in
+            # uname -m and arch seem to behave different under rosetta
+            # https://superuser.com/questions/835514/why-do-uname-p-and-uname-m-and-arch-output-different-architectures
+            case "$(arch)" in
 				x86_64|amd64)
 					_url=${base_url}/${ghver}/x86_64-apple-darwin-ghcup-${ghver}
 					;;
@@ -679,7 +681,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
 
 	do_cabal_config_init $ask_cabal_config_init_answer
 
-	edo cabal new-update
+	edo cabal new-update --ignore-project
 else # don't install ghc and cabal
 	case "${plat}" in
 			MSYS*|MINGW*)

scripts/bootstrap/bootstrap-haskell.ps1

@@ -246,6 +246,7 @@ if ($Silent -and !($InstallDir)) {
       $GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix)
     }
   
+    $GhcupBasePrefix = $GhcupBasePrefix.TrimEnd().TrimStart()
     if (!($GhcupBasePrefix)) {
       Print-Msg -color Red -msg "No directory specified!"
     } elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) {
@@ -333,6 +334,7 @@ if ($CabalDir) {
     $CabalDirPrompt = Read-Host
     $CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
 
+    $CabDirEnv = $CabDirEnv.TrimEnd().TrimStart()
     if (!($CabDirEnv)) {
       Print-Msg -color Red -msg "No directory specified!"         
     } elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
@@ -444,6 +446,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
         Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:' 
         $MsysDir = Read-Host
       }
+      $MsysDir = $MsysDir.TrimEnd().TrimStart()
       if (!($MsysDir)) {
         Print-Msg -color Red -msg "No directory specified!"         
       } elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) {

stack.yaml

@@ -16,7 +16,6 @@ extra-deps:
   - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216
   - haskus-utils-data-1.4@sha256:bfa94363b94b14779edd6834fbd59dbb847c3d7b8f48e3844f456ffdc077da4a,1466
   - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
-  - haskus-utils-variant-3.1@sha256:e602dd23e068c98d03c1027af20503addef8df6368577622453f44ccabea2a5b,2159
   - heaps-0.3.6.1@sha256:7928b759ca5180d35722c45948c0bde264229f3c99c1888188a3d9285f13d3d2,1340
   - hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
   - hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
@@ -40,6 +39,11 @@ extra-deps:
   - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
   - yaml-streamly-0.12.0
 
+  - git: https://github.com/hasufell/packages.git
+    commit: cc0b4688f8bb374fa92f17c856949de795b56291
+    subdirs:
+      - haskus-utils-variant
+
 flags:
   http-io-streams:
     brotli: false