CHANGELOG.md

@@ -1,9 +1,5 @@
 # Revision history for ghcup
 
-## 0.1.16 -- ????-??-??
-
-* Add 'nuke' subcommand wrt [#135](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/135), implemented by Arjun Kathuria
-
 ## 0.1.15.2 -- 2021-06-13
 
 * Remove legacy handling of cabal binary and be more graceful about binaries not installed by ghcup (e.g. stack)

app/ghcup/Main.hs

@@ -1113,10 +1113,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
-                , rawOutter    =
-                    case optCommand of
-                      Nuke -> \_ -> pure ()
-                      _ -> B.appendFile logfile
+                , rawOutter    = B.appendFile logfile
                 }
           let runLogger = myLoggerT loggerConfig
           let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
@@ -1706,27 +1703,31 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
             Nuke ->
               runRm (do
-                   lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
-                   lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
+                   lift $ runLogger $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
+                   lift $ runLogger $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
                    liftIO $ threadDelay 10000000  -- wait 10s
 
-                   lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
-                   lift $ $logInfo "Nuking in 3...2...1"
+                   lift $ runLogger $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
+                   lift $ runLogger $ $logInfo "Nuking in 3...2...1"
               
-                   lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
+
+                   lInstalled <- lift $ runLogger . flip runReaderT appstate $ listVersions Nothing (Just ListInstalled)
 
                    forM_ lInstalled (liftE . rmTool)
 
-                   lift rmGhcupDirs
+                   leftOverFiles <- lift $ runLogger $ runReaderT rmGhcupDirs appstate
+                   pure leftOverFiles
 
                    ) >>= \case
-                            VRight leftOverFiles
-                              | null leftOverFiles -> do
+                            VRight leftOverFiles -> do
+
+                              case length leftOverFiles of
+                                0 -> do
                                   runLogger $ $logInfo "Nuclear Annihilation complete!"
                                   pure ExitSuccess
-                              | otherwise -> do
-                                  runLogger $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
-                                  forM_ leftOverFiles putStrLn
+                                _ -> do
+                                  runLogger $ $logWarn "These Directories/Files have survived Nuclear Annihilation, you may remove them manually."
+                                  forM_ leftOverFiles (runLogger . $logDebug . T.pack)
                                   pure ExitSuccess
 
                             VLeft e -> do

lib/GHCup.hs

@@ -1305,26 +1305,29 @@ rmGhcup = do
                   (liftIO $ canonicalizePath currentRunningExecPath)
 
   p2 <- handleIO' doesNotExistErrorType
-                  (handlePathNotPresent ghcupFilepath)
-                  (liftIO $ canonicalizePath ghcupFilepath)
+                  (handlePathNotPresent ghcupFilename)
+                  (liftIO $ canonicalizePath ghcupFilename)
 
   let areEqualPaths = equalFilePath p1 p2
 
-  when (not areEqualPaths) $ do
-    $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
-
+  if areEqualPaths
+    then
+      do
 #if defined(IS_WINDOWS)
-  -- since it doesn't seem possible to delete a running exec in windows
-  -- we move it to temp dir, to be deleted at next reboot
-  tempDir <- liftIO $ getTemporaryDirectory
-  let tempFilepath = tempDir </> ghcupFilename
-  hideError UnsupportedOperation $
-            liftIO $ hideError NoSuchThing $
-            Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
+    -- since it doesn't seem possible to delete a running exec in windows
+    -- we move it to temp dir, to be deleted at next reboot
+        tempDir <- liftIO $ getTemporaryDirectory
+        let tempFilepath = tempDir </> ghcupFilename
+        hideError UnsupportedOperation $
+                  liftIO $ hideError NoSuchThing $
+                  Win32.moveFileEx ghcupFilepath (Just tempFilepath) 1
 #else
-  -- delete it.
-  hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
+    -- delete it.
+        hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
 #endif
+    else
+      $logWarn $
+      nonStandardInstallLocationMsg currentRunningExecPath
 
   where
     handlePathNotPresent fp _err = do
@@ -1345,74 +1348,83 @@ rmTool :: ( MonadReader AppState m
            -> Excepts '[NotInstalled ] m ()
 
 rmTool ListResult {lVer, lTool, lCross} = do
-  case lTool of
-    GHC ->
-      let ghcTargetVersion = GHCTargetVersion lCross lVer
-      in rmGHCVer ghcTargetVersion
-    HLS -> rmHLSVer lVer
-    Cabal -> rmCabalVer lVer
-    Stack -> rmStackVer lVer
-    GHCup -> lift rmGhcup
+  -- appstate <- ask
 
+  case lTool of
+    GHC -> do
+      let ghcTargetVersion = GHCTargetVersion lCross lVer
+      rmGHCVer ghcTargetVersion
+
+    HLS -> do
+      rmHLSVer lVer
+
+    Cabal -> do
+      rmCabalVer lVer
+
+    Stack -> do
+      rmStackVer lVer
+
+    GHCup -> do
+      lift rmGhcup
 
 rmGhcupDirs :: ( MonadReader AppState m
                , MonadIO m
                , MonadLogger m
                , MonadCatch m
                , MonadMask m )
-            => m [FilePath]
+                => m [FilePath]
 rmGhcupDirs = do
-  Dirs
+  dirs@Dirs
     { baseDir
     , binDir
     , logsDir
     , cacheDir
-    } <- asks dirs
+    , confDir } <- asks dirs
 
   let envFilePath = baseDir </> "env"
 
   confFilePath <- getConfigFilePath
 
-  rmEnvFile  envFilePath
+  -- remove env File
+  rmEnvFile envFilePath
+
+-- remove the configFile file
   rmConfFile confFilePath
+
+  -- remove entire cache Dir
   rmCacheDir cacheDir
-  rmLogsDir  logsDir
-  rmBinDir   binDir
-#if defined(IS_WINDOWS)
-  rmPath (baseDir </> "msys64")
-#endif
 
-  liftIO $ removeEmptyDirsRecursive baseDir
+  -- remove entire logs Dir
+  rmLogsDir logsDir
 
-  -- report files in baseDir that are left-over after
-  -- the standard location deletions above
-  hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
+  -- remove bin directory conditionally
+  rmBinDir binDir
+
+  -- report files in baseDir that are left-over after the standard location deletions above
+  reportRemainingFiles baseDir
 
   where
 
-    rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmEnvFile enFilePath = do
       $logInfo "Removing Ghcup Environment File"
       hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath
 
-    rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmConfFile confFilePath = do
       $logInfo "removing Ghcup Config File"
       hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath
 
-    rmCacheDir :: (MonadLogger m, MonadIO m) => FilePath -> m ()
     rmCacheDir cacheDir = do
       $logInfo "removing ghcup cache Dir"
-      contents <- liftIO $ getDirectoryContentsRecursive cacheDir
-      forM_ contents (liftIO . deleteFile . (cacheDir </>))
+      contents <- liftIO $ listDirectory cacheDir
+      forM_ contents deleteFile
+      removeDirIfEmptyOrIsSymlink cacheDir
 
-    rmLogsDir :: (MonadLogger m, MonadIO m) => FilePath -> m ()
     rmLogsDir logsDir = do
       $logInfo "removing ghcup logs Dir"
-      contents <- liftIO $ getDirectoryContentsRecursive logsDir
-      forM_ contents (liftIO . deleteFile . (logsDir </>))
+      contents <- liftIO $ listDirectory logsDir
+      forM_ contents deleteFile
+      removeDirIfEmptyOrIsSymlink logsDir
 
-    rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     rmBinDir binDir = do
 #if !defined(IS_WINDOWS)
       isXDGStyle <- liftIO $ useXDG
@@ -1423,12 +1435,11 @@ rmGhcupDirs = do
       removeDirIfEmptyOrIsSymlink binDir
 #endif
 
-    reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
-    reportRemainingFiles dir = do
-      remainingFiles <- liftIO $ getDirectoryContentsRecursive dir
+    reportRemainingFiles ghcupDir = do
+      remainingFiles <- liftIO $ getDirectoryContentsRecursive ghcupDir
       let normalizedFilePaths = fmap normalise remainingFiles
       let sortedByDepthRemainingFiles = reverse $ sortBy compareFn normalizedFilePaths
-      let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
+      remainingFilesAbsolute <- makePathsAbsolute sortedByDepthRemainingFiles
 
       pure remainingFilesAbsolute
 
@@ -1439,22 +1450,17 @@ rmGhcupDirs = do
         compareFn :: FilePath -> FilePath -> Ordering
         compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
 
-    removeEmptyDirsRecursive :: FilePath -> IO ()
-    removeEmptyDirsRecursive fp = do
-      cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
-      forM_ cs removeEmptyDirsRecursive
-      hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
-        
+    makePathsAbsolute :: (MonadIO m) => [FilePath] -> m [FilePath]
+    makePathsAbsolute paths = liftIO $
+                              traverse (makeAbsolute . normalise) paths
 
     -- we expect only files inside cache/log dir
     -- we report remaining files/dirs later,
     -- hence the force/quiet mode in these delete functions below.
 
-    deleteFile :: FilePath -> IO ()
     deleteFile filepath = do
       hideError InappropriateType $ rmFile filepath
 
-    removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     removeDirIfEmptyOrIsSymlink filepath =
       hideError UnsatisfiedConstraints $
       handleIO' InappropriateType
@@ -1467,8 +1473,6 @@ rmGhcupDirs = do
           then liftIO $ deleteFile fp
           else liftIO $ ioError e
 
-
-
     ------------------
     --[ Debug info ]--
     ------------------

lib/GHCup/Utils/Prelude.hs

@@ -190,14 +190,14 @@ hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
 hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
 
 
-hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
+hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
 hideErrorDef errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
 
 
-hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
+hideErrorDefM :: [IOErrorType] -> IO a -> IO a -> IO a
 hideErrorDefM errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else ioError e)
 
 
 -- TODO: does this work?
@@ -334,13 +334,12 @@ copyDirectoryRecursive srcDir destDir = do
                    in doCopy src dest
                 | (srcBase, srcFile) <- srcFiles ]
 
-
--- | List all the files in a directory and all subdirectories.
---
--- The order places files in sub-directories after all the files in their
--- parent directories. The list is generated lazily so is not well defined if
--- the source directory structure changes before the list is used.
---
+    -- | List all the files in a directory and all subdirectories.
+    --
+    -- The order places files in sub-directories after all the files in their
+    -- parent directories. The list is generated lazily so is not well defined if
+    -- the source directory structure changes before the list is used.
+    --
 getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
 getDirectoryContentsRecursive topdir = recurseDirectories [""]
   where