hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow to compile from git repo

Browse Source
This commit is contained in:
Julian Ospald 2021-04-28 18:45:48 +02:00
parent 7e0f839ff8
commit 9f0ac0ee19
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
6 changed files with 170 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Revision history for ghcup
## 0.1.15 -- ????-??-??
* Add date to GHC bindist names created by ghcup
* Warn when /tmp doesn't have 5GB or more of disk space
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
## 0.1.14.1 -- 2021-04-11
* Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119)

82
app/ghcup/Main.hs
View File

@ -165,9 +165,8 @@ data RmOptions = RmOptions
data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions
{ targetVer :: Version
{ targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version (Path Abs)
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
@ -177,14 +176,6 @@ data GHCCompileOptions = GHCCompileOptions
, setCompile :: Bool
}
data CabalCompileOptions = CabalCompileOptions
{ targetVer :: Version
, bootstrapGhc :: Either Version (Path Abs)
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
@ -659,7 +650,10 @@ ENV variables:
such as: CC, LD, OBJDUMP, NM, AR, RANLIB.
Examples:
# compile from known version
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2
# compile from git commit/reference
ghcup compile ghc -j 4 -g master -b 8.2.2
# specify path to bootstrap ghc
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
@ -668,34 +662,22 @@ Examples:
ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts =
(\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
)
<$> cabalCompileOpts
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
cabalCompileOpts :: Parser CabalCompileOptions
cabalCompileOpts =
CabalCompileOptions
<$> option
GHCCompileOptions
<$> ((Left <$> option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
) <|>
(Right <$> (GitBranch <$> option
str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
"The git commit/branch/ref to build from"
) <*>
optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"))
)))
<*> option
(eitherReader
(\x ->
@ -742,6 +724,20 @@ cabalCompileOpts =
"Absolute path to patch directory (applied in order, uses -p1)"
)
)
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
<*> flag
False
True
(long "set" <> help
"Set as active version after install"
)
toolVersionParser :: Parser ToolVersion
@ -1470,22 +1466,26 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Compile (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC (do
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
liftE $ compileGHC dls
(GHCTargetVersion crossTarget targetVer)
case targetGhc of
Left targetVer -> do
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
targetVer <- liftE $ compileGHC dls
(first (GHCTargetVersion crossTarget) targetGhc)
bootstrapGhc
jobs
buildConfig
patchDir
addConfArgs
pfreq
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly
setGHC targetVer SetGHCOnly
pure vi
)
>>= \case

156
lib/GHCup.hs
View File

@ -59,6 +59,7 @@ import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.Maybe
import Data.String ( fromString )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Time.Clock
@ -88,6 +89,8 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import GHCup.Utils.MegaParsec
@ -1075,7 +1078,7 @@ compileGHC :: ( MonadMask m
, MonadFail m
)
=> GHCupDownloads
-> GHCTargetVersion -- ^ version to install
-> Either GHCTargetVersion GitBranch -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
@ -1099,38 +1102,81 @@ compileGHC :: ( MonadMask m
#endif
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
GHCTargetVersion
compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
= do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
pure (workdir, tmpUnpack, tver)
-- clone from git
Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
lEM $ git [ "init" ]
lEM $ git [ "remote"
, "add"
, "origin"
, fromString rep ]
let fetch_args =
[ "fetch"
, "--depth"
, "1"
, "--quiet"
, "origin"
, fromString ref ]
lEM $ git fetch_args
lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
CapturedProcess {..} <- liftIO $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr))
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
alreadyInstalled <- lift $ ghcInstalled tver
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
ghcdir <- lift $ ghcupGHCDir tver
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
(bindist, bmk) <- liftE $ runBuildAction
tmpUnpack
Nothing
(do
b <- compileBindist bghc ghcdir workdir
b <- compileBindist bghc tver workdir
bmk <- liftIO $ readFileStrict (build_mk workdir)
pure (b, bmk)
)
@ -1139,7 +1185,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
liftE $ installPackedGHC bindist
(view dlSubdir dlInfo)
(Just $ RegexDir "ghc-.*")
ghcdir
(tver ^. tvVersion)
pfreq
@ -1151,21 +1197,23 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
pure tver
where
defaultConf = case _tvTarget tver of
Nothing -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|]
Just _ -> [s|
defaultConf = case targetGhc of
Left (GHCTargetVersion (Just _) _) -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
_ -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|]
compileBindist :: ( MonadReader AppState m
, MonadThrow m
@ -1175,13 +1223,13 @@ Stage1Only = YES|]
, MonadFail m
)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> GHCTargetVersion
-> Path Abs
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Path Abs) -- ^ output path of bindist
compileBindist bghc ghcdir workdir = do
compileBindist bghc tver workdir = do
lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig
@ -1191,31 +1239,28 @@ Stage1Only = YES|]
cEnv <- liftIO getEnvironment
if
| _tvVersion tver >= [vver|8.8.0|] -> do
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
if | _tvVersion tver >= [vver|8.8.0|] -> do
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
lEM $ execLogged
"./configure"
False
( maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
lEM $ execLogged
"./configure"
False
( ["--prefix=" <> toFilePath ghcdir]
++ maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
lEM $ execLogged
"./configure"
False
( [ "--prefix=" <> toFilePath ghcdir
, "--with-ghc=" <> either toFilePath toFilePath bghc
( [ "--with-ghc=" <> either toFilePath toFilePath bghc
]
++ maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
@ -1283,12 +1328,12 @@ Stage1Only = YES|]
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-- for cross, we need Stage1Only
case _tvTarget tver of
Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
case targetGhc of
Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
)
Nothing -> pure ()
_ -> pure ()
@ -1381,4 +1426,3 @@ postGHCInstall ver@GHCTargetVersion {..} = do
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

5
lib/GHCup/Types.hs
View File

@ -379,6 +379,11 @@ data GHCTargetVersion = GHCTargetVersion
}
deriving (Ord, Eq, Show)
data GitBranch = GitBranch
{ ref :: String
, repo :: Maybe String
}
deriving (Ord, Eq, Show)
mkTVer :: Version -> GHCTargetVersion
mkTVer = GHCTargetVersion Nothing

9
lib/GHCup/Utils.hs
View File

@ -770,6 +770,15 @@ make args workdir = do
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing
makeOut :: [ByteString]
-> Maybe (Path Abs)
-> IO CapturedProcess
makeOut args workdir = do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
liftIO $ executeOut mymake args workdir
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.

9
lib/GHCup/Utils/MegaParsec.hs
View File

@ -67,6 +67,15 @@ ghcTargetBinP t =
<*> (MP.chunk t <* MP.eof)
-- | Extracts the version from @ProjectVersion="8.10.5"@.
ghcProjectVersion :: MP.Parsec Void Text Version
ghcProjectVersion = do
_ <- MP.chunk "ProjectVersion=\""
ver <- parseUntil1 $ MP.chunk "\""
MP.setInput ver
version'
-- | Extracts target triple and version from e.g.
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * armv7-unknown-linux-gnueabihf-8.8.3