diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3ed9f35..1ebceff 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -511,7 +511,7 @@ installCabalUnpacked path inst mver' forceInstall = do unless forceInstall -- Overwrite it when it IS a force install (liftE $ throwIfFileAlreadyExists destPath) - handleIO (throwE . CopyError . show) $ liftIO $ copyFile + copyFileE (path cabalFile <> exeExt) destPath lift $ chmod_755 destPath @@ -661,7 +661,7 @@ installHLSUnpacked path inst mver' forceInstall = do unless forceInstall -- if it is a force install, overwrite it. (liftE $ throwIfFileAlreadyExists destPath) - handleIO (throwE . CopyError . show) $ liftIO $ copyFile + copyFileE srcPath destPath lift $ chmod_755 destPath @@ -677,7 +677,7 @@ installHLSUnpacked path inst mver' forceInstall = do unless forceInstall (liftE $ throwIfFileAlreadyExists destWrapperPath) - handleIO (throwE . CopyError . show) $ liftIO $ copyFile + copyFileE srcWrapperPath destWrapperPath @@ -849,35 +849,37 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc cp <- case cabalProject of Just cp | isAbsolute cp -> do - handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir "cabal.project") + copyFileE cp (workdir "cabal.project") pure "cabal.project" | otherwise -> pure (takeFileName cp) Nothing -> pure "cabal.project" - forM_ cabalProjectLocal $ \cpl -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cpl (workdir cp <.> "local") + forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir cp <.> "local") + + let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"] artifacts <- forM (sort ghcs) $ \ghc -> do let ghcInstallDir = installDir T.unpack (prettyVer ghc) - liftIO $ createDirRecursive' installDir + liftIO $ createDirRecursive' ghcInstallDir lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc liftE $ lEM @_ @'[ProcessError] $ - execLogged "cabal" ( [ "v2-install" + execLogged "cabal" ( [ "v2-build" , "-w" , "ghc-" <> T.unpack (prettyVer ghc) - , "--install-method=copy" ] ++ maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ - [ "--overwrite-policy=always" - , "--disable-profiling" - , "--disable-tests" - , "--enable-split-sections" - , "--enable-executable-stripping" - , "--enable-executable-static" - , "--installdir=" <> ghcInstallDir - , "--project-file=" <> cp - , "exe:haskell-language-server" - , "exe:haskell-language-server-wrapper"] + [ "--project-file=" <> cp + ] ++ targets ) (Just workdir) "cabal" Nothing + forM_ targets $ \target -> do + let cabal = "cabal" + args = ["list-bin", target] + CapturedProcess{..} <- lift $ executeOut cabal args (Just workdir) + case _exitCode of + ExitFailure i -> throwE (NonZeroExit i cabal args) + _ -> pure () + let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut + copyFileE cbin (ghcInstallDir takeFileName cbin) pure ghcInstallDir forM_ artifacts $ \artifact -> do @@ -1038,7 +1040,7 @@ installStackUnpacked path inst mver' forceInstall = do unless forceInstall (liftE $ throwIfFileAlreadyExists destPath) - handleIO (throwE . CopyError . show) $ liftIO $ copyFile + copyFileE (path stackFile <> exeExt) destPath lift $ chmod_755 destPath @@ -2409,7 +2411,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had <> ".tar" <> takeExtension tar) let tarPath = cacheDir tarName - handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir tar) + copyFileE (workdir tar) tarPath lift $ logInfo $ "Copied bindist to " <> T.pack tarPath pure tarPath @@ -2575,7 +2577,7 @@ upgradeGHCup mtarget force' = do lift $ logDebug $ "rm -f " <> T.pack destFile lift $ hideError NoSuchThing $ recycleFile destFile lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile - handleIO (throwE . CopyError . show) $ liftIO $ copyFile p + copyFileE p destFile lift $ chmod_755 destFile diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index ee06c0d..9e6e893 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -24,6 +24,7 @@ import GHCup.Types #endif import GHCup.Types.Optics import {-# SOURCE #-} GHCup.Utils.Logger +import GHCup.Errors import Control.Applicative import Control.Exception.Safe @@ -32,7 +33,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.List ( nub, intercalate, stripPrefix, isPrefixOf ) +import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd ) import Data.Maybe import Data.Foldable import Data.String @@ -509,6 +510,10 @@ recover action = #endif +copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m () +copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from + + -- | Gathering monoidal values -- -- >>> traverseFold (pure . (:["0"])) ["1","2"] @@ -529,6 +534,8 @@ forFold = \t -> (`traverseFold` t) -- -- >>> stripNewline "foo\n\n\n" -- "foo" +-- >>> stripNewline "foo\n\n\nfoo" +-- "foofoo" -- >>> stripNewline "foo\r" -- "foo" -- >>> stripNewline "foo" @@ -540,10 +547,29 @@ stripNewline :: String -> String stripNewline = filter (`notElem` "\n\r") +-- | Strip @\\r@ and @\\n@ from end of 'String'. +-- +-- >>> stripNewlineEnd "foo\n\n\n" +-- "foo" +-- >>> stripNewlineEnd "foo\n\n\nfoo" +-- "foo\n\n\nfoo" +-- >>> stripNewlineEnd "foo\r" +-- "foo" +-- >>> stripNewlineEnd "foo" +-- "foo" +-- +-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t +-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t +stripNewlineEnd :: String -> String +stripNewlineEnd = dropWhileEnd (`elem` "\n\r") + + -- | Strip @\\r@ and @\\n@ from 'Text's -- -- >>> stripNewline' "foo\n\n\n" -- "foo" +-- >>> stripNewline' "foo\n\n\nfoo" +-- "foofoo" -- >>> stripNewline' "foo\r" -- "foo" -- >>> stripNewline' "foo"