Require --isolate to have an absolute directory, fixes #367

app/ghcup/GHCup/OptParse/Common.hs

@@ -226,7 +226,7 @@ absolutePathParser f = case isValid f && isAbsolute f of
               False -> Left "Please enter a valid absolute filepath."
 
 isolateParser :: FilePath -> Either String FilePath
-isolateParser f = case isValid f of
+isolateParser f = case isValid f && isAbsolute f of
               True -> Right $ normalise f
               False -> Left "Please enter a valid filepath for isolate dir."
 

app/ghcup/GHCup/OptParse/Install.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ViewPatterns      #-}
-{-# LANGUAGE TypeOperators     #-}
 
 module GHCup.OptParse.Install where
 
@@ -20,7 +19,6 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
 
@@ -262,7 +260,51 @@ type InstallEffects = '[ AlreadyInstalled
                        , ProcessError
                        , UninstallFailed
                        , MergeFileTreeError
-                       , InstallSetError
+
+                       , (AlreadyInstalled, ())
+                       , (UnknownArchive, ())
+                       , (ArchiveResult, ())
+                       , (FileDoesNotExistError, ())
+                       , (CopyError, ())
+                       , (NotInstalled, ())
+                       , (UninstallFailed, ())
+                       , (MergeFileTreeError, ())
+                       , (DirNotEmpty, ())
+                       , (NoDownload, ())
+                       , (BuildFailed, ())
+                       , (TagNotFound, ())
+                       , (DigestError, ())
+                       , (GPGError, ())
+                       , (DownloadFailed, ())
+                       , (TarDirDoesNotExist, ())
+                       , (NextVerNotFound, ())
+                       , (NoToolVersionSet, ())
+                       , (FileAlreadyExistsError, ())
+                       , (ProcessError, ())
+
+                       , (AlreadyInstalled, NotInstalled)
+                       , (UnknownArchive, NotInstalled)
+                       , (ArchiveResult, NotInstalled)
+                       , (FileDoesNotExistError, NotInstalled)
+                       , (CopyError, NotInstalled)
+                       , (NotInstalled, NotInstalled)
+                       , (DirNotEmpty, NotInstalled)
+                       , (NoDownload, NotInstalled)
+                       , (NotInstalled, NotInstalled)
+                       , (UninstallFailed, NotInstalled)
+                       , (MergeFileTreeError, NotInstalled)
+                       , (BuildFailed, NotInstalled)
+                       , (TagNotFound, NotInstalled)
+                       , (DigestError, NotInstalled)
+                       , (GPGError, NotInstalled)
+                       , (DownloadFailed, NotInstalled)
+                       , (TarDirDoesNotExist, NotInstalled)
+                       , (NextVerNotFound, NotInstalled)
+                       , (NoToolVersionSet, NotInstalled)
+                       , (FileAlreadyExistsError, NotInstalled)
+                       , (ProcessError, NotInstalled)
+
+                       , ((), NotInstalled)
                        ]
 
 
@@ -277,27 +319,58 @@ runInstTool appstate' mInstPlatform =
     @InstallEffects
 
 
-type InstallGHCEffects = '[ AlreadyInstalled
+type InstallGHCEffects = '[ TagNotFound
-                          , ArchiveResult
-                          , BuildFailed
-                          , CopyError
-                          , DigestError
-                          , DirNotEmpty
-                          , DownloadFailed
-                          , FileAlreadyExistsError
-                          , FileDoesNotExistError
-                          , GPGError
-                          , MergeFileTreeError
                           , NextVerNotFound
-                          , NoDownload
                           , NoToolVersionSet
-                          , NotInstalled
+                          , BuildFailed
-                          , ProcessError
+                          , DirNotEmpty
-                          , TagNotFound
+                          , AlreadyInstalled
-                          , TarDirDoesNotExist
                           , UninstallFailed
-                          , UnknownArchive
+                          , MergeFileTreeError
-                          , InstallSetError
+
+                          , (AlreadyInstalled, NotInstalled)
+                          , (UnknownArchive, NotInstalled)
+                          , (ArchiveResult, NotInstalled)
+                          , (FileDoesNotExistError, NotInstalled)
+                          , (CopyError, NotInstalled)
+                          , (NotInstalled, NotInstalled)
+                          , (DirNotEmpty, NotInstalled)
+                          , (NoDownload, NotInstalled)
+                          , (UninstallFailed, NotInstalled)
+                          , (MergeFileTreeError, NotInstalled)
+                          , (BuildFailed, NotInstalled)
+                          , (TagNotFound, NotInstalled)
+                          , (DigestError, NotInstalled)
+                          , (GPGError, NotInstalled)
+                          , (DownloadFailed, NotInstalled)
+                          , (TarDirDoesNotExist, NotInstalled)
+                          , (NextVerNotFound, NotInstalled)
+                          , (NoToolVersionSet, NotInstalled)
+                          , (FileAlreadyExistsError, NotInstalled)
+                          , (ProcessError, NotInstalled)
+
+                          , (AlreadyInstalled, ())
+                          , (UnknownArchive, ())
+                          , (ArchiveResult, ())
+                          , (FileDoesNotExistError, ())
+                          , (CopyError, ())
+                          , (NotInstalled, ())
+                          , (DirNotEmpty, ())
+                          , (NoDownload, ())
+                          , (UninstallFailed, ())
+                          , (MergeFileTreeError, ())
+                          , (BuildFailed, ())
+                          , (TagNotFound, ())
+                          , (DigestError, ())
+                          , (GPGError, ())
+                          , (DownloadFailed, ())
+                          , (TarDirDoesNotExist, ())
+                          , (NextVerNotFound, ())
+                          , (NoToolVersionSet, ())
+                          , (FileAlreadyExistsError, ())
+                          , (ProcessError, ())
+
+                          , ((), NotInstalled)
                           ]
 
 runInstGHC :: AppState
@@ -332,23 +405,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstGHC s' instPlatform $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         liftE $ runBothE' (installGHCBin
+         void $ liftE $ sequenceE (installGHCBin
                      (_tvVersion v)
                      (maybe GHCupInternal IsolateDir isolateDir)
                      forceInstall
                    )
-                   $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
+                   $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
          pure vi
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           liftE $ runBothE' (installGHCBindist
+           void $ liftE $ sequenceE (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                        (_tvVersion v)
                        (maybe GHCupInternal IsolateDir isolateDir)
                        forceInstall
                      )
-                     $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
+                     $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
            pure vi
       )
         >>= \case
@@ -358,18 +431,20 @@ install installCommand settings getAppState' runLogger = case installCommand of
                   runLogger $ logInfo msg
                 pure ExitSuccess
 
-              VLeft e@(V (AlreadyInstalled _ _)) -> do
+              VLeft (V (AlreadyInstalled _ v, ())) -> do
-                runLogger $ logWarn $ T.pack $ prettyShow e
+                runLogger $ logWarn $
+                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
                 pure ExitSuccess
-              VLeft e@(V (AlreadyInstalled _ _)) -> do
+              VLeft (V (AlreadyInstalled _ v)) -> do
-                runLogger $ logWarn $ T.pack $ prettyShow e
+                runLogger $ logWarn $
+                  "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
                 pure ExitSuccess
 
               VLeft (V (DirNotEmpty fp)) -> do
                 runLogger $ logError $
                   "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
-              VLeft (V (DirNotEmpty fp)) -> do
+              VLeft (V (DirNotEmpty fp, ())) -> do
                 runLogger $ logError $
                   "Install directory " <> T.pack fp <> " is not empty."
                 pure $ ExitFailure 3
@@ -381,7 +456,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
                     "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3
-              VLeft err@(V (BuildFailed tmpdir _)) -> do
+              VLeft err@(V (BuildFailed tmpdir _, ())) -> do
                 case keepDirs settings of
                   Never -> runLogger (logError $ T.pack $ prettyShow err)
                   _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
@@ -402,21 +477,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         liftE $ runBothE' (installCabalBin
+         void $ liftE $ sequenceE (installCabalBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
+                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           liftE $ runBothE' (installCabalBindist
+           void $ liftE $ sequenceE (installCabalBindist
                                       (DownloadInfo uri Nothing "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
+                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
            pure vi
       )
       >>= \case
@@ -425,17 +500,19 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp)) -> do
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
@@ -451,22 +528,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
        Nothing -> runInstTool s' instPlatform $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         liftE $ runBothE' (installHLSBin
+         void $ liftE $ sequenceE (installHLSBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
                                     forceInstall
-                                  ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
+                                  ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
          pure vi
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
            -- TODO: support legacy
-           liftE $ runBothE' (installHLSBindist
+           void $ liftE $ sequenceE (installHLSBindist
                                       (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
-                                    ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
+                                    ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
            pure vi
       )
       >>= \case
@@ -475,17 +552,27 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                  "HLS ver "
+                <> prettyVer v
+                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
+                <> prettyVer v
+                <> "'"
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                  "HLS ver "
+                <> prettyVer v
+                <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
+                <> prettyVer v
+                <> "'"
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp)) -> do
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
@@ -501,21 +588,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
         Nothing -> runInstTool s' instPlatform $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          liftE $ runBothE' (installStackBin
+          void $ liftE $ sequenceE (installStackBin
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
-                                   ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
+                                   ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
           pure vi
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
             (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            liftE $ runBothE' (installStackBindist
+            void $ liftE $ sequenceE (installStackBindist
                                        (DownloadInfo uri Nothing "")
                                        v
                                        (maybe GHCupInternal IsolateDir isolateDir)
                                        forceInstall
-                                     ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
+                                     ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
             pure vi
       )
       >>= \case
@@ -524,17 +611,19 @@ install installCommand settings getAppState' runLogger = case installCommand of
               forM_ (_viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
               pure ExitSuccess
             VLeft (V (FileAlreadyExistsError fp)) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3
-            VLeft e@(V (AlreadyInstalled _ _)) -> do
+            VLeft (V (AlreadyInstalled _ v, ())) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $
+                "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
               pure ExitSuccess
-            VLeft (V (FileAlreadyExistsError fp)) -> do
+            VLeft (V (FileAlreadyExistsError fp, ())) -> do
               runLogger $ logWarn $
                 "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
               pure $ ExitFailure 3

ghcup.cabal

@@ -241,7 +241,6 @@ executable ghcup
     , directory             ^>=1.3.6.0
     , filepath              ^>=1.4.2.1
     , ghcup
-    , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
     , libarchive            ^>=3.0.3.0
     , megaparsec            >=8.0.0    && <9.3

lib/GHCup/Errors.hs

@@ -137,13 +137,10 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
 
 instance Pretty AlreadyInstalled where
   pPrint (AlreadyInstalled tool ver') =
-    pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed;"
+    pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
-    <+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'")
-
 
 -- | The Directory is supposed to be empty, but wasn't.
 data DirNotEmpty = DirNotEmpty {path :: FilePath}
-  deriving Show
 
 instance Pretty DirNotEmpty where
   pPrint (DirNotEmpty path) = do
@@ -347,17 +344,6 @@ instance Pretty DownloadFailed where
 
 deriving instance Show DownloadFailed
 
-data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
-
-instance Pretty InstallSetError where
-  pPrint (InstallSetError reason1 reason2) =
-     text "Both installation and setting the tool failed. Install error was:"
-      <+> pPrint reason1
-      <+> text "\nSet error was:"
-      <+> pPrint reason2
-
-deriving instance Show InstallSetError
-
 
 -- | A build failed.
 data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

lib/GHCup/Prelude.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
 
 {-|
 Module      : GHCup.Prelude
@@ -28,7 +27,6 @@ module GHCup.Prelude
   )
 where
 
-import           GHCup.Errors
 import           GHCup.Prelude.Internal
 import           GHCup.Types.Optics   (HasLog)
 import           GHCup.Prelude.Logger (logWarn)
@@ -54,29 +52,3 @@ catchWarn :: forall es m env . ( Pretty (V es)
                              , Monad m) => Excepts es m () -> Excepts '[] m ()
 catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
 
-
-runBothE' :: forall e m a b .
-             ( Monad m
-             , Show (V e)
-             , Pretty (V e)
-             , PopVariant InstallSetError e
-             , LiftVariant' e (InstallSetError ': e)
-             , e :<< (InstallSetError ': e)
-             )
-          => Excepts e m a
-          -> Excepts e m b
-          -> Excepts (InstallSetError ': e) m ()
-runBothE' a1 a2 = do
-   r1 <- lift $ runE @e a1
-   r2 <- lift $ runE @e a2
-   case (r1, r2) of
-      (VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)
-      (VLeft e , _       ) -> throwSomeE e
-      (_       , VLeft e ) -> throwSomeE e
-      (VRight _, VRight _) -> pure ()
-
-
--- | Throw some exception
-throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
-{-# INLINABLE throwSomeE #-}
-throwSomeE = Excepts . pure . VLeft . liftVariant