diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 07a92dc..2d2f6aa 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -69,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 @@ -87,7 +87,7 @@ data HLSCompileOptions = HLSCompileOptions , isolateDir :: Maybe FilePath , cabalProject :: Maybe (Either FilePath URI) , cabalProjectLocal :: Maybe URI - , patchDir :: Maybe FilePath + , patches :: Maybe (Either FilePath [URI]) , targetGHCs :: [ToolVersion] , cabalArgs :: [Text] } @@ -200,13 +200,23 @@ ghcCompileOpts = "Absolute path to build config file" ) ) - <*> optional - (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 + ( + (fmap Right $ many $ option + (eitherReader uriParser) + (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 @@ -313,13 +323,23 @@ hlsCompileOpts = "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over." ) ) - <*> optional - (option - (eitherReader absolutePathParser) - (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help - "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)" + <*> (optional + ( + (fmap Right $ many $ option + (eitherReader uriParser) + (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 (toolVersionOption Nothing (Just GHC)) <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)")) @@ -436,7 +456,7 @@ compile compileCommand settings runAppState runLogger = do isolateDir cabalProject cabalProjectLocal - patchDir + patches cabalArgs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls @@ -484,7 +504,7 @@ compile compileCommand settings runAppState runLogger = do bootstrapGhc jobs buildConfig - patchDir + patches addConfArgs buildFlavour hadrian diff --git a/lib/GHCup.hs b/lib/GHCup.hs index f3131d0..5a86ba2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -62,7 +62,7 @@ import Data.String ( fromString ) import Data.Text ( Text ) import Data.Time.Clock import Data.Time.Format.ISO8601 -import Data.Versions +import Data.Versions hiding ( patch ) import Distribution.Types.Version hiding ( Version ) import Distribution.Types.PackageId import Distribution.Types.PackageDescription @@ -753,7 +753,7 @@ compileHLS :: ( MonadMask m -> Maybe FilePath -> Maybe (Either FilePath URI) -> Maybe URI - -> Maybe FilePath + -> Maybe (Either FilePath [URI]) -- ^ patches -> [Text] -- ^ additional args to cabal install -> Excepts '[ NoDownload , GPGError @@ -765,7 +765,7 @@ compileHLS :: ( MonadMask m , BuildFailed , NotInstalled ] m Version -compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir cabalArgs = do +compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo Dirs { .. } <- lift getDirs @@ -842,7 +842,7 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc liftIO $ createDirRecursive' installDir -- apply patches - forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) + liftE $ applyAnyPatch patches workdir -- set up project files cp <- case cabalProject of @@ -2096,7 +2096,7 @@ compileGHC :: ( MonadMask m -> Either Version FilePath -- ^ version to bootstrap with -> Maybe Int -- ^ jobs -> Maybe FilePath -- ^ build config - -> Maybe FilePath -- ^ patch directory + -> Maybe (Either FilePath [URI]) -- ^ patches -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool @@ -2125,7 +2125,7 @@ compileGHC :: ( MonadMask m ] m GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir +compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -2149,7 +2149,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo) - forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) + liftE $ applyAnyPatch patches workdir pure (workdir, tmpUnpack, tver) @@ -2157,7 +2157,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had Right GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH] DownloadFailed $ do + tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lEM $ git [ "init" ] @@ -2177,7 +2177,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack) + liftE $ applyAnyPatch patches tmpUnpack lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" CapturedProcess {..} <- lift $ makeOut @@ -2852,3 +2852,25 @@ rmTmp = do let p = tmpdir f logDebug $ "rm -rf " <> T.pack p rmPathForcibly p + + +applyAnyPatch :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadUnliftIO m + , MonadCatch m + , MonadResource m + , MonadThrow m + , MonadMask m + , MonadIO m) + => Maybe (Either FilePath [URI]) + -> FilePath + -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () +applyAnyPatch Nothing _ = pure () +applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir +applyAnyPatch (Just (Right uris)) workdir = do + tmpUnpack <- lift withGHCupTmpDir + forM_ uris $ \uri -> do + patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False + liftE $ applyPatch patch workdir diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 489e856..3ee7478 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -67,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 @@ -892,15 +892,22 @@ applyPatches pdir ddir = do execBlank ([s|.+\.(patch|diff)$|] :: ByteString) ) - forM_ (sort patches) $ \patch' -> do - lift $ logInfo $ "Applying patch " <> T.pack patch' - fmap (either (const Nothing) Just) - (exec - "patch" - ["-p1", "-i", patch'] - (Just ddir) - Nothing) - !? PatchFailed + forM_ (sort patches) $ \patch' -> applyPatch patch' ddir + + +applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) + => FilePath -- ^ Patch + -> FilePath -- ^ dir to apply patches in + -> Excepts '[PatchFailed] m () +applyPatch patch ddir = do + 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