Compare commits
	
		
			1 Commits
		
	
	
		
	
	| Author | SHA1 | Date | |
|---|---|---|---|
| a3867484cc | 
@ -41,6 +41,7 @@ import           Data.Aeson                     ( decodeStrict', Value )
 | 
			
		||||
import           Data.Aeson.Encode.Pretty       ( encodePretty )
 | 
			
		||||
import           Data.Either
 | 
			
		||||
import           Data.Functor
 | 
			
		||||
import           Data.Versions (version)
 | 
			
		||||
import           Data.Maybe
 | 
			
		||||
import           GHC.IO.Encoding
 | 
			
		||||
import           Haskus.Utils.Variant.Excepts
 | 
			
		||||
@ -341,12 +342,14 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
 | 
			
		||||
  alreadyInstalling (Install (Left (InstallCabal InstallOptions{..})))   (Cabal, ver)    = cmp' Cabal instVer ver
 | 
			
		||||
  alreadyInstalling (Install (Left (InstallHLS InstallOptions{..})))     (HLS, ver)      = cmp' HLS instVer ver
 | 
			
		||||
  alreadyInstalling (Install (Left (InstallStack InstallOptions{..})))   (Stack, ver)    = cmp' Stack instVer ver
 | 
			
		||||
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
 | 
			
		||||
    (GHC, ver)   = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver
 | 
			
		||||
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ overwriteVer = Just [S over] })) (GHC, ver)
 | 
			
		||||
    | Right over' <- version (T.pack over) = cmp' GHC (Just $ GHCVersion (mkTVer over')) ver
 | 
			
		||||
    | otherwise = pure False
 | 
			
		||||
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))
 | 
			
		||||
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion tver) ver
 | 
			
		||||
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
 | 
			
		||||
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion over) ver
 | 
			
		||||
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ overwriteVer = Just [S over] })) (HLS, ver)
 | 
			
		||||
    | Right over' <- version (T.pack over) = cmp' HLS (Just $ ToolVersion over') ver
 | 
			
		||||
    | otherwise = pure False
 | 
			
		||||
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver }))
 | 
			
		||||
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion tver) ver
 | 
			
		||||
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))
 | 
			
		||||
 | 
			
		||||
@ -17,7 +17,6 @@ import           GHCup.Platform
 | 
			
		||||
import           GHCup.Types
 | 
			
		||||
import           GHCup.Types.Optics
 | 
			
		||||
import           GHCup.Utils
 | 
			
		||||
import           GHCup.Utils.URI
 | 
			
		||||
import           GHCup.Prelude
 | 
			
		||||
import           GHCup.Prelude.Process
 | 
			
		||||
import           GHCup.Prelude.Logger
 | 
			
		||||
@ -78,7 +77,6 @@ import qualified Cabal.Config            as CC
 | 
			
		||||
    --[ Types ]--
 | 
			
		||||
    -------------
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- a superset of ToolVersion
 | 
			
		||||
data SetToolVersion = SetGHCVersion GHCTargetVersion
 | 
			
		||||
                    | SetToolVersion Version
 | 
			
		||||
@ -314,6 +312,29 @@ gpgParser s' | t == T.pack "strict" = Right GPGStrict
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
overWriteVersionParser :: String -> Either String [VersionPattern]
 | 
			
		||||
overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack
 | 
			
		||||
 where
 | 
			
		||||
  versionPattern :: MP.Parsec Void Text VersionPattern
 | 
			
		||||
  versionPattern = do
 | 
			
		||||
    str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%')
 | 
			
		||||
    if str' /= mempty
 | 
			
		||||
    then pure (S str')
 | 
			
		||||
    else     fmap (const CabalVer)      v_cabal
 | 
			
		||||
         <|> fmap (const GitBranchName) b_name
 | 
			
		||||
         <|> fmap (const GitHashShort)  s_hash
 | 
			
		||||
         <|> fmap (const GitHashLong)   l_hash
 | 
			
		||||
         <|> fmap (const GitDescribe)   g_desc
 | 
			
		||||
         <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k"
 | 
			
		||||
   where
 | 
			
		||||
    v_cabal = MP.chunk "%v"
 | 
			
		||||
    b_name  = MP.chunk "%b"
 | 
			
		||||
    s_hash  = MP.chunk "%h"
 | 
			
		||||
    l_hash  = MP.chunk "%H"
 | 
			
		||||
    g_desc  = MP.chunk "%g"
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
    ------------------
 | 
			
		||||
    --[ Completers ]--
 | 
			
		||||
    ------------------
 | 
			
		||||
 | 
			
		||||
@ -36,7 +36,7 @@ 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 )
 | 
			
		||||
import           Options.Applicative.Help.Pretty ( text, vsep )
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import           System.Exit
 | 
			
		||||
 | 
			
		||||
@ -74,7 +74,7 @@ data GHCCompileOptions = GHCCompileOptions
 | 
			
		||||
  , crossTarget  :: Maybe Text
 | 
			
		||||
  , addConfArgs  :: [Text]
 | 
			
		||||
  , setCompile   :: Bool
 | 
			
		||||
  , ovewrwiteVer :: Maybe Version
 | 
			
		||||
  , overwriteVer :: Maybe [VersionPattern]
 | 
			
		||||
  , buildFlavour :: Maybe String
 | 
			
		||||
  , buildSystem  :: Maybe BuildSystem
 | 
			
		||||
  , isolateDir   :: Maybe FilePath
 | 
			
		||||
@ -86,7 +86,7 @@ data HLSCompileOptions = HLSCompileOptions
 | 
			
		||||
  , jobs         :: Maybe Int
 | 
			
		||||
  , setCompile   :: Bool
 | 
			
		||||
  , updateCabal  :: Bool
 | 
			
		||||
  , ovewrwiteVer :: Either Bool Version
 | 
			
		||||
  , overwriteVer :: Maybe [VersionPattern]
 | 
			
		||||
  , isolateDir   :: Maybe FilePath
 | 
			
		||||
  , cabalProject :: Maybe (Either FilePath URI)
 | 
			
		||||
  , cabalProjectLocal :: Maybe URI
 | 
			
		||||
@ -155,8 +155,8 @@ Examples:
 | 
			
		||||
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 using 'git describe' to name the binary and ignore the pinned index state
 | 
			
		||||
  ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
 | 
			
		||||
  # 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|]
 | 
			
		||||
 | 
			
		||||
@ -253,11 +253,16 @@ ghcCompileOpts =
 | 
			
		||||
    <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
 | 
			
		||||
    <*> optional
 | 
			
		||||
          (option
 | 
			
		||||
            (eitherReader
 | 
			
		||||
              (first (const "Not a valid version") . version . T.pack)
 | 
			
		||||
            (eitherReader overWriteVersionParser
 | 
			
		||||
            )
 | 
			
		||||
            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
 | 
			
		||||
              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
 | 
			
		||||
            (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)
 | 
			
		||||
            )
 | 
			
		||||
          )
 | 
			
		||||
@ -343,19 +348,25 @@ hlsCompileOpts =
 | 
			
		||||
    <*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")
 | 
			
		||||
    <*>
 | 
			
		||||
         (
 | 
			
		||||
          (Right <$> option
 | 
			
		||||
            (eitherReader
 | 
			
		||||
              (first (const "Not a valid version") . version . T.pack)
 | 
			
		||||
          optional (option
 | 
			
		||||
            (eitherReader overWriteVersionParser
 | 
			
		||||
            )
 | 
			
		||||
            (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help
 | 
			
		||||
              "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
 | 
			
		||||
            (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)
 | 
			
		||||
            )
 | 
			
		||||
          )
 | 
			
		||||
          <|>
 | 
			
		||||
          (Left <$> (switch
 | 
			
		||||
          ((\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
 | 
			
		||||
                      )
 | 
			
		||||
                    )
 | 
			
		||||
          )
 | 
			
		||||
@ -529,7 +540,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
 | 
			
		||||
                    targetHLS
 | 
			
		||||
                    ghcs
 | 
			
		||||
                    jobs
 | 
			
		||||
                    ovewrwiteVer
 | 
			
		||||
                    overwriteVer
 | 
			
		||||
                    (maybe GHCupInternal IsolateDir isolateDir)
 | 
			
		||||
                    cabalProject
 | 
			
		||||
                    cabalProjectLocal
 | 
			
		||||
@ -576,7 +587,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
 | 
			
		||||
        targetVer <- liftE $ compileGHC
 | 
			
		||||
                    targetGhc
 | 
			
		||||
                    crossTarget
 | 
			
		||||
                    ovewrwiteVer
 | 
			
		||||
                    overwriteVer
 | 
			
		||||
                    bootstrapGhc
 | 
			
		||||
                    jobs
 | 
			
		||||
                    buildConfig
 | 
			
		||||
 | 
			
		||||
@ -807,7 +807,7 @@ compileGHC :: ( MonadMask m
 | 
			
		||||
              )
 | 
			
		||||
           => GHCVer
 | 
			
		||||
           -> Maybe Text               -- ^ cross target
 | 
			
		||||
           -> Maybe Version            -- ^ overwrite version
 | 
			
		||||
           -> Maybe [VersionPattern]
 | 
			
		||||
           -> Either Version FilePath  -- ^ version to bootstrap with
 | 
			
		||||
           -> Maybe Int                -- ^ jobs
 | 
			
		||||
           -> Maybe FilePath           -- ^ build config
 | 
			
		||||
@ -843,12 +843,12 @@ compileGHC :: ( MonadMask m
 | 
			
		||||
                 ]
 | 
			
		||||
                m
 | 
			
		||||
                GHCTargetVersion
 | 
			
		||||
compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
 | 
			
		||||
compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir
 | 
			
		||||
  = do
 | 
			
		||||
    pfreq@PlatformRequest { .. } <- lift getPlatformReq
 | 
			
		||||
    GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
 | 
			
		||||
 | 
			
		||||
    (workdir, tmpUnpack, tver) <- case targetGhc of
 | 
			
		||||
    (workdir, tmpUnpack, tver, ov) <- case targetGhc of
 | 
			
		||||
      -- unpack from version tarball
 | 
			
		||||
      SourceDist ver -> do
 | 
			
		||||
        lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap
 | 
			
		||||
@ -870,7 +870,11 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
                         (view dlSubdir dlInfo)
 | 
			
		||||
        liftE $ applyAnyPatch patches (fromGHCupPath workdir)
 | 
			
		||||
 | 
			
		||||
        pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver))
 | 
			
		||||
        ov <- case vps of
 | 
			
		||||
                Just vps' -> fmap Just $ expandVersionPattern (Just ver) "" "" "" "" vps'
 | 
			
		||||
                Nothing   -> pure Nothing
 | 
			
		||||
 | 
			
		||||
        pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver), ov)
 | 
			
		||||
 | 
			
		||||
      RemoteDist uri -> do
 | 
			
		||||
        lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
 | 
			
		||||
@ -894,13 +898,17 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
 | 
			
		||||
        let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
 | 
			
		||||
 | 
			
		||||
        pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
 | 
			
		||||
        ov <- case vps of
 | 
			
		||||
                Just vps' -> fmap Just $ expandVersionPattern tver "" "" "" "" vps'
 | 
			
		||||
                Nothing   -> pure Nothing
 | 
			
		||||
 | 
			
		||||
        pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver, ov)
 | 
			
		||||
 | 
			
		||||
      -- clone from git
 | 
			
		||||
      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, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
 | 
			
		||||
        (tver, ov) <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, 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" ]
 | 
			
		||||
@ -932,6 +940,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
                          then pure Nothing
 | 
			
		||||
                          else fmap Just $ liftE $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
 | 
			
		||||
          chash <- liftE $ gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
 | 
			
		||||
          branch <- liftE $ gitOut ["rev-parse", "--abbrev-ref", "HEAD" ] (fromGHCupPath tmpUnpack)
 | 
			
		||||
 | 
			
		||||
          -- clone submodules
 | 
			
		||||
          lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
 | 
			
		||||
@ -949,9 +958,19 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
                           (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)
 | 
			
		||||
          liftIO $ threadDelay 5000000 -- give the user a sec to intervene
 | 
			
		||||
 | 
			
		||||
          pure tver
 | 
			
		||||
          ov <- case vps of
 | 
			
		||||
                  Just vps' -> fmap Just $ expandVersionPattern
 | 
			
		||||
                                             tver
 | 
			
		||||
                                             (take 7 $ T.unpack chash)
 | 
			
		||||
                                             (T.unpack chash)
 | 
			
		||||
                                             (maybe "" T.unpack git_describe)
 | 
			
		||||
                                             (T.unpack branch)
 | 
			
		||||
                                             vps'
 | 
			
		||||
                  Nothing -> pure Nothing
 | 
			
		||||
 | 
			
		||||
        pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver)
 | 
			
		||||
          pure (tver, ov)
 | 
			
		||||
 | 
			
		||||
        pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver, ov)
 | 
			
		||||
    -- the version that's installed may differ from the
 | 
			
		||||
    -- compiled version, so the user can overwrite it
 | 
			
		||||
    installVer <- if | Just ov'   <- ov   -> pure (GHCTargetVersion crossTarget ov')
 | 
			
		||||
@ -1091,7 +1110,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
  compileHadrianBindist tver workdir ghcdir = do
 | 
			
		||||
    liftE $ configureBindist tver workdir ghcdir
 | 
			
		||||
 | 
			
		||||
    lift $ logInfo "Building (this may take a while)..."
 | 
			
		||||
    lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..."
 | 
			
		||||
    hadrian_build <- liftE $ findHadrianFile workdir
 | 
			
		||||
    lEM $ execLogged hadrian_build
 | 
			
		||||
                          ( maybe [] (\j  -> ["-j" <> show j]         ) jobs
 | 
			
		||||
@ -1163,7 +1182,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
 | 
			
		||||
 | 
			
		||||
    liftE $ checkBuildConfig (build_mk workdir)
 | 
			
		||||
 | 
			
		||||
    lift $ logInfo "Building (this may take a while)..."
 | 
			
		||||
    lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..."
 | 
			
		||||
    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
 | 
			
		||||
 | 
			
		||||
    if | isCross tver -> do
 | 
			
		||||
 | 
			
		||||
@ -335,7 +335,7 @@ compileHLS :: ( MonadMask m
 | 
			
		||||
           => HLSVer
 | 
			
		||||
           -> [Version]
 | 
			
		||||
           -> Maybe Int
 | 
			
		||||
           -> Either Bool Version
 | 
			
		||||
           -> Maybe [VersionPattern]
 | 
			
		||||
           -> InstallDir
 | 
			
		||||
           -> Maybe (Either FilePath URI)
 | 
			
		||||
           -> Maybe URI
 | 
			
		||||
@ -353,7 +353,7 @@ compileHLS :: ( MonadMask m
 | 
			
		||||
                       , BuildFailed
 | 
			
		||||
                       , NotInstalled
 | 
			
		||||
                       ] m Version
 | 
			
		||||
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
 | 
			
		||||
compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
 | 
			
		||||
  pfreq@PlatformRequest { .. } <- lift getPlatformReq
 | 
			
		||||
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
 | 
			
		||||
  Dirs { .. } <- lift getDirs
 | 
			
		||||
@ -362,7 +362,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
    lift $ logInfo "Updating cabal DB"
 | 
			
		||||
    lEM $ exec "cabal" ["update"] (Just $ fromGHCupPath tmpDir) Nothing
 | 
			
		||||
 | 
			
		||||
  (workdir, tmpUnpack, tver, git_describe) <- case targetHLS of
 | 
			
		||||
  (workdir, tmpUnpack, tver, ov) <- case targetHLS of
 | 
			
		||||
    -- unpack from version tarball
 | 
			
		||||
    SourceDist tver -> do
 | 
			
		||||
      lift $ logDebug $ "Requested to compile: " <> prettyVer tver
 | 
			
		||||
@ -382,7 +382,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
                       (liftE . intoSubdir tmpUnpack)
 | 
			
		||||
                       (view dlSubdir dlInfo)
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, Nothing)
 | 
			
		||||
      ov <- case vps of
 | 
			
		||||
              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
 | 
			
		||||
              Nothing   -> pure Nothing
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, ov)
 | 
			
		||||
 | 
			
		||||
    HackageDist tver -> do
 | 
			
		||||
      lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver
 | 
			
		||||
@ -396,7 +400,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
 | 
			
		||||
      let workdir = appendGHCupPath tmpUnpack hls
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, Nothing)
 | 
			
		||||
      ov <- case vps of
 | 
			
		||||
              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
 | 
			
		||||
              Nothing   -> pure Nothing
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, ov)
 | 
			
		||||
 | 
			
		||||
    RemoteDist uri -> do
 | 
			
		||||
      lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
 | 
			
		||||
@ -419,7 +427,11 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
 | 
			
		||||
      let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, Nothing)
 | 
			
		||||
      ov <- case vps of
 | 
			
		||||
              Just vps' -> fmap Just $ expandVersionPattern (Just tver) "" "" "" "" vps'
 | 
			
		||||
              Nothing   -> pure Nothing
 | 
			
		||||
 | 
			
		||||
      pure (workdir, tmpUnpack, tver, ov)
 | 
			
		||||
 | 
			
		||||
    -- clone from git
 | 
			
		||||
    GitDist GitBranch{..} -> do
 | 
			
		||||
@ -459,28 +471,31 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
                        then pure Nothing
 | 
			
		||||
                        else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
 | 
			
		||||
        chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
 | 
			
		||||
        branch <- gitOut ["rev-parse", "--abbrev-ref", "HEAD" ] (fromGHCupPath tmpUnpack)
 | 
			
		||||
        tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")
 | 
			
		||||
 | 
			
		||||
        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
 | 
			
		||||
 | 
			
		||||
        ov <- case vps of
 | 
			
		||||
                Just vps' -> fmap Just $ expandVersionPattern
 | 
			
		||||
                                           (Just tver)
 | 
			
		||||
                                           (take 7 $ T.unpack chash)
 | 
			
		||||
                                           (T.unpack chash)
 | 
			
		||||
                                           (maybe "" T.unpack git_describe)
 | 
			
		||||
                                           (T.unpack branch)
 | 
			
		||||
                                           vps'
 | 
			
		||||
                Nothing -> pure Nothing
 | 
			
		||||
 | 
			
		||||
        lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
 | 
			
		||||
                                    "HLS version (from cabal file): " <> prettyVer tver <>
 | 
			
		||||
                                    "\n  branch: " <> branch <>
 | 
			
		||||
                                    (if not shallow_clone then "\n  " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
 | 
			
		||||
                                    (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)
 | 
			
		||||
 | 
			
		||||
        pure (tmpUnpack, tmpUnpack, tver, git_describe)
 | 
			
		||||
        pure (tmpUnpack, tmpUnpack, tver, ov)
 | 
			
		||||
 | 
			
		||||
  -- the version that's installed may differ from the
 | 
			
		||||
  -- compiled version, so the user can overwrite it
 | 
			
		||||
  installVer <- case ov of
 | 
			
		||||
                  Left True -> case git_describe of
 | 
			
		||||
                                 -- git describe
 | 
			
		||||
                                 Just h -> either (fail . displayException) pure . version $ h
 | 
			
		||||
                                 -- git describe, but not building from git, lol
 | 
			
		||||
                                 Nothing -> pure tver
 | 
			
		||||
                  -- default: use detected version
 | 
			
		||||
                  Left False -> pure tver
 | 
			
		||||
                  -- overwrite version with users value
 | 
			
		||||
                  Right v -> pure v
 | 
			
		||||
  installVer <- maybe (pure tver) pure ov
 | 
			
		||||
 | 
			
		||||
  liftE $ runBuildAction
 | 
			
		||||
    tmpUnpack
 | 
			
		||||
@ -558,9 +573,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 | 
			
		||||
 | 
			
		||||
  pure installVer
 | 
			
		||||
 where
 | 
			
		||||
  gitDescribeRequested = case ov of
 | 
			
		||||
                           Left b -> b
 | 
			
		||||
                           _      -> False
 | 
			
		||||
  gitDescribeRequested = maybe False (GitDescribe `elem`) vps
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
    -----------------
 | 
			
		||||
 | 
			
		||||
@ -777,3 +777,13 @@ instance Pretty ToolVersion where
 | 
			
		||||
data BuildSystem = Hadrian
 | 
			
		||||
                 | Make
 | 
			
		||||
  deriving (Show, Eq)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
data VersionPattern = CabalVer
 | 
			
		||||
                    | GitHashShort
 | 
			
		||||
                    | GitHashLong
 | 
			
		||||
                    | GitDescribe
 | 
			
		||||
                    | GitBranchName
 | 
			
		||||
                    | S String
 | 
			
		||||
  deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
@ -1275,3 +1275,29 @@ processBranches str' = let lines'   = lines (T.unpack str')
 | 
			
		||||
                           branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
 | 
			
		||||
                       in branches
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
    ------------------
 | 
			
		||||
    --[ Versioning ]--
 | 
			
		||||
    ------------------
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
expandVersionPattern :: MonadFail m
 | 
			
		||||
                     => Maybe Version  -- ^ cabal ver
 | 
			
		||||
                     -> String         -- ^ git hash (short), if any
 | 
			
		||||
                     -> String         -- ^ git hash (long), if any
 | 
			
		||||
                     -> String         -- ^ git describe output, if any
 | 
			
		||||
                     -> String         -- ^ git branch name, if any
 | 
			
		||||
                     -> [VersionPattern]
 | 
			
		||||
                     -> m Version
 | 
			
		||||
expandVersionPattern cabalVer gitHashS gitHashL gitDescribe gitBranch
 | 
			
		||||
  = either (fail . displayException) pure . version . T.pack . go
 | 
			
		||||
 where
 | 
			
		||||
  go [] = ""
 | 
			
		||||
  go (CabalVer:xs) = T.unpack (maybe "" prettyVer cabalVer) <> go xs
 | 
			
		||||
  go (GitHashShort:xs) = gitHashS <> go xs
 | 
			
		||||
  go (GitHashLong:xs) = gitHashL <> go xs
 | 
			
		||||
  go (GitDescribe:xs) = gitDescribe <> go xs
 | 
			
		||||
  go (GitBranchName:xs) = gitBranch <> go xs
 | 
			
		||||
  go (S str:xs) = str <> go xs
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
@ -47,7 +47,7 @@ mkDefaultHLSCompileOptions target ghcs =
 | 
			
		||||
    Nothing
 | 
			
		||||
    True
 | 
			
		||||
    False
 | 
			
		||||
    (Left False)
 | 
			
		||||
    Nothing
 | 
			
		||||
    Nothing
 | 
			
		||||
    Nothing
 | 
			
		||||
    Nothing
 | 
			
		||||
@ -91,8 +91,8 @@ compileGhcCheckList = mapSecond CompileGHC
 | 
			
		||||
  , (baseCmd <> "--cross-target armv7-unknown-linux-gnueabihf", baseOptions{GHC.crossTarget = Just "armv7-unknown-linux-gnueabihf"})
 | 
			
		||||
  , (baseCmd <> "-- --enable-unregisterised", baseOptions{GHC.addConfArgs = ["--enable-unregisterised"]})
 | 
			
		||||
  , (baseCmd <> "--set", baseOptions{GHC.setCompile = True})
 | 
			
		||||
  , (baseCmd <> "-o 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $(versionQ "9.4.5-p1")})
 | 
			
		||||
  , (baseCmd <> "--overwrite-version 9.4.5-p1", baseOptions{GHC.ovewrwiteVer = Just $(versionQ "9.4.5-p1")})
 | 
			
		||||
  , (baseCmd <> "-o 9.4.5-p1", baseOptions{GHC.overwriteVer = Just [S "9.4.5-p1"]})
 | 
			
		||||
  , (baseCmd <> "--overwrite-version 9.4.5-p1", baseOptions{GHC.overwriteVer = Just [S "9.4.5-p1"]})
 | 
			
		||||
  , (baseCmd <> "-f make", baseOptions{GHC.buildFlavour = Just "make"})
 | 
			
		||||
  , (baseCmd <> "--flavour make", baseOptions{GHC.buildFlavour = Just "make"})
 | 
			
		||||
  , (baseCmd <> "--hadrian", baseOptions{GHC.buildSystem = Just Hadrian})
 | 
			
		||||
@ -158,9 +158,9 @@ compileHlsCheckList = mapSecond CompileHLS
 | 
			
		||||
  , (baseCmd <> "--jobs 10", baseOptions{HLS.jobs = Just 10})
 | 
			
		||||
  , (baseCmd <> "--no-set", baseOptions{HLS.setCompile = False})
 | 
			
		||||
  , (baseCmd <> "--cabal-update", baseOptions{HLS.updateCabal = True})
 | 
			
		||||
  , (baseCmd <> "-o 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $(versionQ "2.0.0.0-p1")})
 | 
			
		||||
  , (baseCmd <> "--overwrite-version 2.0.0.0-p1", baseOptions{HLS.ovewrwiteVer = Right $(versionQ "2.0.0.0-p1")})
 | 
			
		||||
  , (baseCmd <> "--git-describe-version", baseOptions{HLS.ovewrwiteVer = Left True})
 | 
			
		||||
  , (baseCmd <> "-o 2.0.0.0-p1", baseOptions{HLS.overwriteVer = Just [S "2.0.0.0-p1"]})
 | 
			
		||||
  , (baseCmd <> "--overwrite-version 2.0.0.0-p1", baseOptions{HLS.overwriteVer = Just [S "2.0.0.0-p1"]})
 | 
			
		||||
  , (baseCmd <> "--git-describe-version", baseOptions{HLS.overwriteVer = Just [GitDescribe]})
 | 
			
		||||
#ifdef IS_WINDOWS
 | 
			
		||||
  , (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})
 | 
			
		||||
  , (baseCmd <> "--isolate C:\\\\tmp\\out_dir", baseOptions{HLS.isolateDir = Just "C:\\\\tmp\\out_dir"})
 | 
			
		||||
 | 
			
		||||
		Loading…
	
		Reference in New Issue
	
	Block a user