{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} 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 import GHCup.Utils import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Concurrent (threadDelay) import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Bifunctor import Data.Functor import Data.Maybe import Data.Versions ( Version, prettyVer, version, pvp ) import qualified Data.Versions as V import Data.Text ( Text ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text, vsep ) import Prelude hiding ( appendFile ) import System.Exit import URI.ByteString hiding ( uriParser ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask, displayException) import System.FilePath (isPathSeparator) import Text.Read (readEither) ---------------- --[ Commands ]-- ---------------- data CompileCommand = CompileGHC GHCCompileOptions | CompileHLS HLSCompileOptions deriving (Eq, Show) --------------- --[ Options ]-- --------------- data GHCCompileOptions = GHCCompileOptions { targetGhc :: GHC.GHCVer , bootstrapGhc :: Either Version FilePath , jobs :: Maybe Int , buildConfig :: Maybe FilePath , patches :: Maybe (Either FilePath [URI]) , crossTarget :: Maybe Text , addConfArgs :: [Text] , setCompile :: Bool , overwriteVer :: Maybe [VersionPattern] , buildFlavour :: Maybe String , buildSystem :: Maybe BuildSystem , isolateDir :: Maybe FilePath } deriving (Eq, Show) data HLSCompileOptions = HLSCompileOptions { targetHLS :: HLS.HLSVer , jobs :: Maybe Int , setCompile :: Bool , updateCabal :: Bool , overwriteVer :: Maybe [VersionPattern] , isolateDir :: Maybe FilePath , cabalProject :: Maybe (Either FilePath URI) , cabalProjectLocal :: Maybe URI , patches :: Maybe (Either FilePath [URI]) , targetGHCs :: [ToolVersion] , cabalArgs :: [Text] } deriving (Eq, Show) --------------- --[ Parsers ]-- --------------- compileP :: Parser CompileCommand compileP = subparser ( command "ghc" ( CompileGHC <$> info (ghcCompileOpts <**> helper) ( progDesc "Compile GHC from source" <> footerDoc (Just $ text compileFooter) ) ) <> command "hls" ( CompileHLS <$> info (hlsCompileOpts <**> helper) ( progDesc "Compile HLS from source" <> footerDoc (Just $ text compileHLSFooter) ) ) ) where compileFooter = [s|Discussion: Compiles and installs the specified GHC version into a self-contained "~/.ghcup/ghc/" directory and symlinks the ghc binaries to "~/.ghcup/bin/-". This also allows building a cross-compiler. Consult the documentation first: ENV variables: Various toolchain variables will be passed onto the ghc build system, 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 ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|] compileHLSFooter = [s|Discussion: Compiles and installs the specified HLS version. The --ghc arguments are necessary to specify which GHC version to build for/against. These need to be available in PATH prior to compilation. Examples: # compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update # compile from master for ghc 9.2.3, appending the short git commit hash to the version and ignore the pinned index state ghcup compile hls -g master -o '%v-%h' --ghc 9.2.3 -- --index-state=@(date '+%s') # compile a specific commit for ghc 9.2.3 and set a specific version for the binary name ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|] ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = GHCCompileOptions <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) ) (short 'v' <> long "version" <> metavar "VERSION" <> help "The tool version to compile" <> (completer $ versionCompleter [] GHC) ) ) <|> (GHC.GitDist <$> (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)" <> 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 -> (bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path") ) ) ( short 'b' <> long "bootstrap-ghc" <> metavar "BOOTSTRAP_GHC" <> help "The GHC version (or full path) to bootstrap with (must be installed)" <> (completer $ versionCompleter [] GHC) ) <*> optional (option (eitherReader (readEither @Int)) (short 'j' <> long "jobs" <> metavar "JOBS" <> help "How many jobs to use for make" <> (completer $ listCompleter $ fmap show ([1..12] :: [Int])) ) ) <*> optional (option str (short 'c' <> long "config" <> metavar "CONFIG" <> help "Absolute path to build config file" <> completer (bashCompleter "file") ) ) <*> (optional ( (fmap Right $ many $ option (eitherReader uriParser) (long "patch" <> metavar "PATCH_URI" <> help "URI to a patch (https/http/file)" <> completer fileUri ) ) <|> (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. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)" <> completer (bashCompleter "directory") ) ) ) ) <*> 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 compile configure, prefix with '-- ' (longopts)")) <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install")) <*> optional (option (eitherReader overWriteVersionParser ) (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> helpDoc (Just $ vsep [ text "Overwrite the finally installed VERSION with a different one. Allows to specify patterns" , text "%v version" , text "%b branch name" , text "%h short commit hash" , text "%H long commit hash" , text "%g 'git describe' output" ]) <> (completer $ versionCompleter [] GHC) ) ) <*> optional (option str (short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" ) ) <*> ( (\b -> if b then Just Hadrian else Nothing) <$> switch (long "hadrian" <> help "Use the hadrian build system instead of make. Tries to detect by default." ) <|> (\b -> if b then Just Make else Nothing) <$> switch (long "make" <> help "Use the make build system instead of hadrian. Tries to detect by default." ) ) <*> optional (option (eitherReader isolateParser) ( short 'i' <> long "isolate" <> metavar "DIR" <> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made" <> completer (bashCompleter "directory") ) ) hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts = HLSCompileOptions <$> ((HLS.HackageDist <$> option (eitherReader ((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack) ) (short 'v' <> long "version" <> metavar "VERSION" <> help "The version to compile (pulled from hackage)" <> (completer $ versionCompleter' [] HLS (either (const False) (const True) . V.pvp . V.prettyVer)) ) ) <|> (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)" ) <*> optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)" <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"]) )) )) <|> (HLS.SourceDist <$> (option (eitherReader (first (const "Not a valid version") . version . T.pack) ) (long "source-dist" <> metavar "VERSION" <> help "The version to compile (pulled from packaged git sources)" <> (completer $ versionCompleter [] HLS) ) )) <|> ( HLS.RemoteDist <$> (option (eitherReader uriParser) (long "remote-source-dist" <> metavar "URI" <> help "URI (https/http/file) to a HLS source distribution" <> completer fileUri ) ) ) ) <*> optional (option (eitherReader (readEither @Int)) (short 'j' <> long "jobs" <> metavar "JOBS" <> help "How many jobs to use for make" <> (completer $ listCompleter $ fmap show ([1..12] :: [Int])) ) ) <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install")) <*> switch (long "cabal-update" <> help "Run 'cabal update' before the build") <*> ( optional (option (eitherReader overWriteVersionParser ) (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> helpDoc (Just $ vsep [ text "Overwrite the finally installed VERSION with a different one. Allows to specify patterns" , text "%v version from cabal file" , text "%b branch name" , text "%h short commit hash" , text "%H long commit hash" , text "%g 'git describe' output" ]) <> (completer $ versionCompleter [] HLS) ) ) <|> ((\b -> if b then Just [GitDescribe] else Nothing) <$> (switch (long "git-describe-version" <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary." <> internal ) ) ) ) <*> optional (option (eitherReader isolateParser) ( short 'i' <> long "isolate" <> metavar "DIR" <> help "install in an isolated absolute directory instead of the default one, no symlinks to this installation will be made" <> completer (bashCompleter "directory") ) ) <*> optional (option ((fmap Right $ eitherReader uriParser) <|> (fmap Left str)) (long "cabal-project" <> metavar "CABAL_PROJECT" <> help "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme." <> completer fileUri ) ) <*> optional (option (eitherReader uriParser) (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over." <> completer fileUri ) ) <*> (optional ( (fmap Right $ many $ option (eitherReader uriParser) (long "patch" <> metavar "PATCH_URI" <> help "URI to a patch (https/http/file)" <> completer fileUri ) ) <|> (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)" <> completer (bashCompleter "directory") ) ) ) ) <*> some ( option (eitherReader ghcVersionTagEither) ( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)" <> completer (tagCompleter GHC []) <> completer (versionCompleter [] GHC)) ) <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)")) --------------------------- --[ Effect interpreters ]-- --------------------------- type GHCEffects = '[ AlreadyInstalled , BuildFailed , DigestError , ContentLengthError , GPGError , DownloadFailed , GHCupSetError , NoDownload , NotFoundInPATH , PatchFailed , UnknownArchive , TarDirDoesNotExist , NotInstalled , DirNotEmpty , ArchiveResult , FileDoesNotExistError , HadrianNotFound , InvalidBuildConfig , ProcessError , CopyError , BuildFailed , UninstallFailed , MergeFileTreeError ] type HLSEffects = '[ AlreadyInstalled , BuildFailed , DigestError , ContentLengthError , GPGError , DownloadFailed , GHCupSetError , NoDownload , NotFoundInPATH , PatchFailed , UnknownArchive , TarDirDoesNotExist , TagNotFound , DayNotFound , NextVerNotFound , NoToolVersionSet , NotInstalled , DirNotEmpty , ArchiveResult , UninstallFailed , MergeFileTreeError ] runCompileGHC :: (MonadUnliftIO m, MonadIO m) => (ReaderT AppState m (VEither GHCEffects a) -> m (VEither GHCEffects a)) -> Excepts GHCEffects (ResourceT (ReaderT AppState m)) a -> m (VEither GHCEffects a) runCompileGHC runAppState = runAppState . runResourceT . runE @GHCEffects runCompileHLS :: (MonadUnliftIO m, MonadIO m) => (ReaderT AppState m (VEither HLSEffects a) -> m (VEither HLSEffects a)) -> Excepts HLSEffects (ResourceT (ReaderT AppState m)) a -> m (VEither HLSEffects a) runCompileHLS runAppState = runAppState . runResourceT . runE @HLSEffects ------------------ --[ Entrypoint ]-- ------------------ compile :: ( Monad m , MonadMask m , MonadUnliftIO m , MonadFail m ) => CompileCommand -> Settings -> Dirs -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode compile compileCommand settings Dirs{..} runAppState runLogger = do case compileCommand of (CompileHLS HLSCompileOptions { .. }) -> do runCompileHLS runAppState (do case targetHLS of HLS.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (mkTVer targetVer) HLS dls forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene _ -> pure () ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) targetVer <- liftE $ compileHLS targetHLS ghcs jobs overwriteVer (maybe GHCupInternal IsolateDir isolateDir) cabalProject cabalProjectLocal updateCabal patches cabalArgs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (mkTVer targetVer) HLS dls when setCompile $ void $ liftE $ setHLS targetVer SetHLSOnly Nothing pure (vi, targetVer) ) >>= \case VRight (vi, tv) -> do runLogger $ logInfo "HLS successfully compiled and installed" forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg liftIO $ putStr (T.unpack $ prettyVer tv) pure ExitSuccess VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyHFError err _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <> "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 9 (CompileGHC GHCCompileOptions {..}) -> runCompileGHC runAppState (do case targetGhc of GHC.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (mkTVer targetVer) GHC dls forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene _ -> pure () targetVer <- liftE $ compileGHC targetGhc crossTarget overwriteVer bootstrapGhc jobs buildConfig patches addConfArgs buildFlavour buildSystem (maybe GHCupInternal IsolateDir isolateDir) GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls when setCompile $ void $ liftE $ setGHC targetVer SetGHCOnly Nothing pure (vi, targetVer) ) >>= \case VRight (vi, tv) -> do runLogger $ logInfo "GHC successfully compiled and installed" forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg liftIO $ putStr (T.unpack $ tVerToText tv) pure ExitSuccess VLeft (V (AlreadyInstalled _ v)) -> do runLogger $ logWarn $ "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall" pure ExitSuccess VLeft (V (DirNotEmpty fp)) -> do runLogger $ logError $ "Install directory " <> T.pack fp <> " is not empty." pure $ ExitFailure 3 VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyHFError err _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <> "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 9