diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 311bde0..3ec5d32 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -12,6 +12,8 @@ module GHCup.OptParse.Compile where import GHCup +import qualified GHCup.GHC as GHC +import qualified GHCup.HLS as HLS import GHCup.Errors import GHCup.Types import GHCup.Types.Optics @@ -64,7 +66,7 @@ data CompileCommand = CompileGHC GHCCompileOptions data GHCCompileOptions = GHCCompileOptions - { targetGhc :: Either Version GitBranch + { targetGhc :: GHC.GHCVer Version , bootstrapGhc :: Either Version FilePath , jobs :: Maybe Int , buildConfig :: Maybe FilePath @@ -80,7 +82,7 @@ data GHCCompileOptions = GHCCompileOptions data HLSCompileOptions = HLSCompileOptions - { targetHLS :: HLSVer + { targetHLS :: HLS.HLSVer , jobs :: Maybe Int , setCompile :: Bool , ovewrwiteVer :: Either Bool Version @@ -163,7 +165,7 @@ Examples: ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = GHCCompileOptions - <$> ((Left <$> option + <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) ) @@ -172,7 +174,7 @@ ghcCompileOpts = <> (completer $ versionCompleter Nothing GHC) ) ) <|> - (Right <$> (GitBranch <$> option + (GHC.GitDist <$> (GitBranch <$> option str (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from" @@ -181,7 +183,18 @@ ghcCompileOpts = short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)" <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"]) )) - ))) + )) + <|> + ( + GHC.RemoteDist <$> (option + (eitherReader uriParser) + (long "remote-source-dist" <> metavar "URI" <> help + "URI (https/http/file) to a GHC source distribution" + <> completer fileUri + ) + ) + ) + ) <*> option (eitherReader (\x -> @@ -273,7 +286,7 @@ ghcCompileOpts = hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts = HLSCompileOptions - <$> ((SourceDist <$> option + <$> ((HLS.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) ) @@ -283,7 +296,7 @@ hlsCompileOpts = ) ) <|> - (GitDist <$> (GitBranch <$> option + (HLS.GitDist <$> (GitBranch <$> option str (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)" @@ -293,7 +306,7 @@ hlsCompileOpts = )) )) <|> - (HackageDist <$> (option + (HLS.HackageDist <$> (option (eitherReader (first (const "Not a valid version") . version . T.pack) ) @@ -304,7 +317,7 @@ hlsCompileOpts = )) <|> ( - RemoteDist <$> (option + HLS.RemoteDist <$> (option (eitherReader uriParser) (long "remote-source-dist" <> metavar "URI" <> help "URI (https/http/file) to a HLS source distribution" @@ -493,7 +506,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do (CompileHLS HLSCompileOptions { .. }) -> do runCompileHLS runAppState (do case targetHLS of - SourceDist targetVer -> do + HLS.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls forM_ (_viPreCompile =<< vi) $ \msg -> do @@ -544,7 +557,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do (CompileGHC GHCCompileOptions {..}) -> runCompileGHC runAppState (do case targetGhc of - Left targetVer -> do + GHC.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls forM_ (_viPreCompile =<< vi) $ \msg -> do @@ -552,9 +565,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do lift $ logInfo "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - Right _ -> pure () + _ -> pure () targetVer <- liftE $ compileGHC - (first (GHCTargetVersion crossTarget) targetGhc) + ((\case + GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v + GHC.GitDist g -> GHC.GitDist g + GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc) ovewrwiteVer bootstrapGhc jobs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7d55e57..5e48d25 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -14,6 +14,8 @@ module Main where import BrickMain ( brickMain ) #endif +import qualified GHCup.GHC as GHC +import qualified GHCup.HLS as HLS import GHCup.OptParse import GHCup.Download @@ -338,13 +340,13 @@ Report bugs at |] alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver - alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver })) + alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver })) (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over })) (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver - alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = SourceDist tver })) + alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver })) (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver - alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HackageDist tver })) + alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver })) (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True alreadyInstalling _ _ = pure False diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 1d5c295..785b05a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -33,8 +33,8 @@ module GHCup ( import GHCup.Cabal -import GHCup.GHC -import GHCup.HLS +import GHCup.GHC hiding ( GHCVer(..) ) +import GHCup.HLS hiding ( HLSVer(..) ) import GHCup.Stack import GHCup.List import GHCup.Download diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 1bfe494..aa1aff5 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -80,6 +80,12 @@ import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP +data GHCVer v = SourceDist v + | GitDist GitBranch + | RemoteDist URI + + + --------------------- --[ Tool fetching ]-- --------------------- @@ -607,7 +613,7 @@ compileGHC :: ( MonadMask m , MonadUnliftIO m , MonadFail m ) - => Either GHCTargetVersion GitBranch -- ^ version to install + => GHCVer GHCTargetVersion -> Maybe Version -- ^ overwrite version -> Either Version FilePath -- ^ version to bootstrap with -> Maybe Int -- ^ jobs @@ -650,7 +656,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball - Left tver -> do + SourceDist tver -> do lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap -- download source tarball @@ -671,8 +677,31 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr pure (workdir, tmpUnpack, tver) + RemoteDist uri -> do + lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri) + + -- download source tarball + tmpDownload <- lift withGHCupTmpDir + tmpUnpack <- lift mkGhcupTmpDir + tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False + (bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do + liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar + let regex = [s|^(.*/)*boot$|] :: B.ByteString + [bootFile] <- liftIO $ findFilesDeep + tmpUnpack + (makeRegexOpts compExtended + execBlank + regex + ) + tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile)) + pure (bootFile, tver) + + let workdir = appendGHCupPath tmpUnpack (takeDirectory bf) + + pure (workdir, tmpUnpack, mkTVer tver) + -- clone from git - Right GitBranch{..} -> do + GitDist GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do @@ -715,14 +744,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) -- bootstrap - lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - CapturedProcess {..} <- lift $ makeOut - ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) - tver <- case _exitCode of - ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut - ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) - + tver <- liftE $ getGHCVer tmpUnpack liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> "GHC version (from Makefile): " <> prettyVer tver <> @@ -795,11 +817,29 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr pure installVer where + getGHCVer :: ( MonadReader env m + , HasSettings env + , HasDirs env + , HasLog env + , MonadIO m + , MonadThrow m + ) + => GHCupPath + -> Excepts '[ProcessError] m Version + getGHCVer tmpUnpack = do + lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + CapturedProcess {..} <- lift $ makeOut + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) + case _exitCode of + ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut + ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ] + defaultConf = let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) in case targetGhc of - Left (GHCTargetVersion (Just _) _) -> cross_mk + SourceDist (GHCTargetVersion (Just _) _) -> cross_mk _ -> default_mk compileHadrianBindist :: ( MonadReader env m @@ -976,7 +1016,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr -- for cross, we need Stage1Only case targetGhc of - Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE + SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE (InvalidBuildConfig [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] ) diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 1f5779e..8aeb218 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -71,6 +71,12 @@ import qualified Text.Megaparsec as MP import Text.PrettyPrint.HughesPJClass (prettyShow) +data HLSVer = SourceDist Version + | GitDist GitBranch + | HackageDist Version + | RemoteDist URI + + -------------------- --[ Installation ]-- @@ -394,8 +400,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do unpackToDir (fromGHCupPath tmpUnpack) tar - let regex = [s|haskell-language-server\.cabal$|] :: B.ByteString - [cabalFile] <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep + let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString + [cabalFile] <- liftIO $ findFilesDeep tmpUnpack (makeRegexOpts compExtended execBlank diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index d59037d..39af732 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -654,12 +654,3 @@ isSafeDir (IsolateDirResolved _) = False isSafeDir (GHCupDir _) = True isSafeDir (GHCupBinDir _) = False - - - -data HLSVer = SourceDist Version - | GitDist GitBranch - | HackageDist Version - | RemoteDist URI - - diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 07817d6..687fb0d 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1097,7 +1097,8 @@ runBuildAction bdir action = do -- | Clean up the given directory if the action fails, -- depending on the Settings. -cleanUpOnError :: ( MonadReader env m +cleanUpOnError :: forall e m a env . + ( MonadReader env m , HasDirs env , HasSettings env , MonadIO m