Merge branch 'issue-281'
This commit is contained in:
commit
f08cbe70fb
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -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
|
||||
|
|
|
|||
40
lib/GHCup.hs
40
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue