diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Version history for ghcup +## 0.2.6.0 -- 2026-06-11 + +### Bugfixes affecting VSCode + +* Fix filtering in `ghcup list` wrt [#1354](https://github.com/haskell/ghcup-hs/issues/1354) +* Fix `ghcup run` with hls [#1357](https://github.com/haskell/ghcup-hs/issues/1357) + +### Other bugfixes + +* Fix `ghcup compile -o '%v-pre'` wrt [#1361](https://github.com/haskell/ghcup-hs/issues/1361) +* Add missing `--disable-ld-override` to GHC bindist configure runs + +### Improvements + +* Support installing symlinks via installTheSpec [#1351](https://github.com/haskell/ghcup-hs/issues/1351) +* Add `--docs=TARGET` to 'ghcup compile ghc' +* Implement tui show criteria [#1353](https://github.com/haskell/ghcup-hs/issues/1353) +* Add release channels info to the `--help` by Divam +* Allows bash substitution in domain variables wrt [#1342](https://github.com/haskell/ghcup-hs/issues/1342) + ## 0.2.5.0 -- 2026-05-26 * Fix broken `ghcup whereis` on non-installed tools wrt [#1347](https://github.com/haskell/ghcup-hs/issues/1347) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -169,10 +169,19 @@ ) let main_footer = [s|Discussion: - ghcup installs the Glasgow Haskell Compiler from the official + ghcup installs the Haskell development tools from the configured release channels, enabling you to easily switch between different versions. It maintains a self-contained ~/.ghcup directory. +Release Channels: + * default: maintained by GHCup (recommended) + * cross: contains experimental cross compilers + * prereleases: contains pre-releases of all tools + * vanilla: similar to default but only uses upstream bindists + (no patches/fixes are applied, no missing platforms added) + * 3rdparty: access to non-core tools (e.g. hlint, ormolu, agda) +More details at + ENV variables: * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories @@ -299,9 +308,9 @@ res <- case optCommand of #if defined(BRICK) - Interactive -> do + Interactive ioOptions -> do (appState, _) <- liftIO $ getAppState_and_updateCheckAction - liftIO $ brickMain appState >> pure ExitSuccess + liftIO $ brickMain appState ioOptions >> pure ExitSuccess #endif Install installCommand -> install installCommand settings (getAppState_and_updateCheckAction, leanAppstate) Test testCommand -> test testCommand settings (getAppState_and_updateCheckAction, leanAppstate) diff --git a/bench/BenchList.hs b/bench/BenchList.hs --- a/bench/BenchList.hs +++ b/bench/BenchList.hs @@ -55,7 +55,7 @@ [] -- list criteria ShowUpdates -- showRevisions False -- hideOld - True -- showNightly + NShowAll -- showNightly (Nothing, Nothing) pure r @@ -66,6 +66,6 @@ [] -- list criteria ShowUpdates -- showRevisions False -- hideOld - True -- showNightly + NShowAll -- showNightly (Nothing, Nothing) diff --git a/ghcup.cabal b/ghcup.cabal --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup -version: 0.2.5.0 +version: 0.2.6.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2024 @@ -142,7 +142,7 @@ , attoparsec ^>= 0.14 , base >=4.12 && <5 , bytestring >=0.10 && <0.13 - , containers ^>=0.6 || ^>=0.7 + , containers ^>=0.6 || ^>=0.7 || ^>=0.8 , deepseq ^>=1.4 || ^>=1.5 || ^>=1.6 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 @@ -223,6 +223,7 @@ GHCup.Hardcoded.URLs GHCup.Hardcoded.Version GHCup.Input.Parsers + GHCup.Input.Parsers.Domain GHCup.Input.Parsers.URI GHCup.Input.Prompts GHCup.Input.SymlinkSpec @@ -274,8 +275,8 @@ , base16-bytestring >=0.1.1.6 && <1.1 , binary ^>=0.8.6.0 || ^>=0.9 || ^>=0.10 , bz2 ^>=1.0.1.1 - , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 - , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 + , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 || ^>= 3.16.0.0 + , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 || ^>= 3.16.0.0 , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 , conduit ^>=1.3 @@ -362,6 +363,7 @@ GHCup.OptParse.Rm GHCup.OptParse.Run GHCup.OptParse.Set + GHCup.OptParse.TUI GHCup.OptParse.Test GHCup.OptParse.ToolRequirements GHCup.OptParse.UnSet @@ -402,6 +404,7 @@ build-depends: , ghcup + , ghcup-optparse , brick >=2.1 && <2.13 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 || ^>=6.3 || ^>=6.4 @@ -465,7 +468,7 @@ , aeson-pretty ^>=0.8.8 , base >=4.12 && <5 , bytestring >=0.10 && <0.13 - , containers ^>=0.6 || ^>=0.7 + , containers ^>=0.6 || ^>=0.7 || ^>=0.8 , conduit ^>=1.3 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -9,6 +9,7 @@ module GHCup.OptParse.Common , module GHCup.OptParse.Install , module GHCup.OptParse.Test + , module GHCup.OptParse.TUI , module GHCup.OptParse.Set , module GHCup.OptParse.UnSet , module GHCup.OptParse.Rm @@ -37,6 +38,7 @@ import GHCup.OptParse.Common import GHCup.OptParse.Install import GHCup.OptParse.Test +import GHCup.OptParse.TUI import GHCup.OptParse.Set import GHCup.OptParse.UnSet import GHCup.OptParse.Rm @@ -120,7 +122,7 @@ #endif | Nuke #if defined(BRICK) - | Interactive + | Interactive InteractiveOptions #endif | Prefetch PrefetchCommand | GC GCOptions @@ -203,9 +205,9 @@ #if defined(BRICK) ( command "tui" - ( (\_ -> Interactive) + ( Interactive <$> info - helper + (interactiveParser <**> helper) ( progDesc "Start the interactive GHCup UI" ) ) diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -151,6 +151,12 @@ revisionCompleter :: Completer revisionCompleter = listCompleter ["updates", "all", "none"] +nightlyCompleter :: Completer +nightlyCompleter = listCompleter ["latest", "all", "none"] + +docsCompleter :: Completer +docsCompleter = listCompleter ["none", "no-haddocks", "no-sphinx", "no-sphinx-html", "no-sphinx-pdfs", "no-sphinx-man"] + toolCompleter :: Completer toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"] @@ -338,7 +344,7 @@ runEnv = flip runReaderT appState . runE - (VRight installedVersions) <- runEnv $ listVersions (Just [tool]) criteria ShowUpdates False False (Nothing, Nothing) + (VRight installedVersions) <- runEnv $ listVersions (Just [tool]) criteria ShowUpdates False NShowNone (Nothing, Nothing) return $ fmap (T.unpack . prettyVer) . filter filter' . maybe [] (fmap lVer . snd) $ M.lookup tool installedVersions @@ -495,7 +501,7 @@ checkForUpdates = do dl@GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo pfreq <- getPlatformReq - (VRight lInstalled') <- runE $ listVersions Nothing [ListInstalled True] ShowUpdates False False (Nothing, Nothing) + (VRight lInstalled') <- runE $ listVersions Nothing [ListInstalled True] ShowUpdates False NShowNone (Nothing, Nothing) let latestInstalled tool = do (_, xs) <- M.lookup tool lInstalled' ListResult{..} <- lastMay xs diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -86,6 +86,7 @@ , buildSystem :: Maybe BuildSystem , isolateDir :: Maybe FilePath , installTargets :: Maybe [String] + , docs :: Maybe String } deriving (Eq, Show) @@ -173,7 +174,7 @@ ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = - (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir installTargets -> GHCCompileOptions {..}) + (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir installTargets docs -> GHCCompileOptions {..}) <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) @@ -327,6 +328,11 @@ <> completer (listCompleter ["install", "install_bin", "install_lib", "install_extra", "install_man", "install_docs", "install_data", "update_package_db"]) ) ) + <*> optional (option str + ( long "docs" <> metavar "none|no-haddocks|no-sphinx|no-sphinx-html|no-sphinx-pdfs|no-sphinx-man" <> help "Disable some or all of the docs" + <> completer docsCompleter + ) + ) hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts = @@ -642,6 +648,7 @@ buildSystem instDir installTargets + docs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vm = getVersionMetadata targetVer ghc dls case instDir of diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -16,7 +16,7 @@ import GHCup.Errors import GHCup.Prelude import GHCup.Types -import GHCup.Input.Parsers (dayParser, toolParserWithGHCup, criteriaParser, revisionShowParser) +import GHCup.Input.Parsers (dayParser, toolParserWithGHCup, criteriaParser, revisionShowParser, nightlyShowParser) import GHCup.OptParse.Common import GHCup.Prelude.String.QQ import GHCup.Compat.Terminal @@ -65,7 +65,7 @@ , lFrom :: Maybe Day , lTo :: Maybe Day , lHideOld :: Bool - , lShowNightly :: Bool + , lShowNightly :: ShowNightly , lRawFormat :: Bool , lShowRevisions :: ShowRevisions } deriving (Eq, Show) @@ -120,9 +120,18 @@ <*> switch (short 'o' <> long "hide-old" <> help "Hide 'old' tool versions (installed ones are always shown)" ) - <*> switch - (short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)" + <*> (option + (eitherReader nightlyShowParser) + (long "show-nightlies" <> help "How to show nightlies (default: latest)" + <> metavar "" + <> completer nightlyCompleter + <> value NShowLatest ) + <|> fmap (\_ -> NShowAll) (switch + (short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)" + ) + ) + ) <*> switch (short 'r' <> long "raw-format" <> help "More machine-parsable format" ) diff --git a/lib-opt/GHCup/OptParse/Nuke.hs b/lib-opt/GHCup/OptParse/Nuke.hs --- a/lib-opt/GHCup/OptParse/Nuke.hs +++ b/lib-opt/GHCup/OptParse/Nuke.hs @@ -69,7 +69,7 @@ lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀" lift $ logInfo "Nuking in 3...2...1" - lInstalled' <- liftE $ listVersions Nothing [ListInstalled True] ShowNone False True (Nothing, Nothing) + lInstalled' <- liftE $ listVersions Nothing [ListInstalled True] ShowNone False NShowAll (Nothing, Nothing) iforM_ lInstalled' $ \tool (_, ls) -> forM_ ls $ \ListResult{..} -> liftE $ rmToolVersion tool (TargetVersion lCross lVer) diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -514,18 +514,17 @@ setHLS' v tmp = do Dirs {..} <- getDirs legacy <- isLegacyHLS v + hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? NotInstalled hls (mkTVer v) + cw <- liftIO $ canonicalizePath (binDir hlsWrapper) + liftIO $ print cw + lift $ createLink (relativeSymlink tmp cw) (tmp takeFileName cw) + liftIO $ print $ relativeSymlink tmp cw + hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir )) + forM_ hlsBins $ \bin -> + lift $ createLink (relativeSymlink tmp bin) (tmp takeFileName bin) if legacy - then do - -- TODO: factor this out - hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? NotInstalled hls (mkTVer v) - cw <- liftIO $ canonicalizePath (binDir hlsWrapper) - lift $ createLink (relativeSymlink tmp cw) (tmp takeFileName cw) - hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir )) - forM_ hlsBins $ \bin -> - lift $ createLink (relativeSymlink tmp bin) (tmp takeFileName bin) - liftE $ setHLS v SetHLSOnly (Just tmp) - else do - liftE $ void $ setToolVersion' hls (mkTVer v) (Just tmp) + then liftE $ setHLS v SetHLSOnly (Just tmp) + else liftE $ setHLS v SetHLS_XYZ (Just tmp) createTmpDir :: ( MonadIOish m ) => Toolchain diff --git a/lib-opt/GHCup/OptParse/TUI.hs b/lib-opt/GHCup/OptParse/TUI.hs new file mode 100644 --- /dev/null +++ b/lib-opt/GHCup/OptParse/TUI.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} + +module GHCup.OptParse.TUI where + +import GHCup.Command.List +import GHCup.Types +import GHCup.Input.Parsers (dayParser, toolParserWithGHCup, criteriaParser, revisionShowParser, nightlyShowParser) +import GHCup.OptParse.Common + +import Data.Functor +import Data.Maybe +import Data.Time.Calendar ( Day ) +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) + + + + --------------- + --[ Options ]-- + --------------- + + +data InteractiveOptions = InteractiveOptions + { ioTool :: Maybe [Tool] + , ioCriteria :: [ListCriteria] + , ioFrom :: Maybe Day + , ioTo :: Maybe Day + , ioHideOld :: Bool + , ioShowNightly :: ShowNightly + , ioShowRevisions :: ShowRevisions + } deriving (Eq, Show) + + + + --------------- + --[ Parsers ]-- + --------------- + +interactiveParser :: Parser InteractiveOptions +interactiveParser = + InteractiveOptions + <$> optional + (some + (option + (eitherReader toolParserWithGHCup) + (short 't' <> long "tool" <> metavar "" <> help + "Tool to list versions for. Default is all" + <> completer toolCompleter + ) + ) + ) + <*> many + (option + (eitherReader criteriaParser) + ( short 'c' + <> long "show-criteria" + <> metavar "" + <> help "Apply filtering criteria, prefix with + or -" + <> completer (listCompleter + [ "+installed", "+set", "+available", "-installed", "-set", "-available"]) + ) + ) + <*> optional + (option + (eitherReader dayParser) + (short 's' <> long "since" <> metavar "YYYY-MM-DD" <> help + "List only tools with release date starting at YYYY-MM-DD or later" + <> completer toolCompleter + ) + ) + <*> optional + (option + (eitherReader dayParser) + (short 'u' <> long "until" <> metavar "YYYY-MM-DD" <> help + "List only tools with release date earlier than YYYY-MM-DD" + <> completer toolCompleter + ) + ) + <*> switch + (short 'o' <> long "hide-old" <> help "Hide 'old' tool versions (installed ones are always shown)" + ) + <*> (option + (eitherReader nightlyShowParser) + (long "show-nightlies" <> help "How to show nightlies (default: latest)" + <> metavar "" + <> completer nightlyCompleter + <> value NShowLatest + ) + <|> fmap (\_ -> NShowAll) (switch + (short 'n' <> long "show-nightly" <> help "Show nightlies (installed ones are always shown)" + ) + ) + ) + <*> option + (eitherReader revisionShowParser) + (long "show-revisions" <> help "How to show revisions (default: updates)" + <> metavar "" + <> completer revisionCompleter + <> value ShowUpdates + ) + + + + + + + + + + diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} module GHCup.Brick.Actions where @@ -121,7 +122,7 @@ -> Maybe BrickInternalState -> BrickInternalState constructList appD settings = - replaceLR (filterVisible (_showAllVersions settings)) + replaceLR (filterVisible (Common._showAllVersions settings)) (_lr appD) -- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 @@ -161,16 +162,16 @@ (V.fromList $ fmap (\(tool, (td, filter filterF -> lr)) -> (tool, (td, L.list (Singular tool) (V.fromList lr) 1))) $ M.toList list_result) 1 - filterVisible :: Bool -> ListResult -> Bool -filterVisible v e | lInstalled e = True - | v - , Nightly `notElem` lTag e = True - | not v - , Old `notElem` lTag e - , Nightly `notElem` lTag e = True - | otherwise = (Old `notElem` lTag e) && - (Nightly `notElem` lTag e) +filterVisible showAll e + | lInstalled e = True + | showAll + = True + | not showAll + , Old `notElem` lTag e + = True + | otherwise + = Old `notElem` lTag e -- | Suspend the current UI and run an IO action in terminal. If the -- IO action returns a Left value, then it's thrown as userError. @@ -188,7 +189,7 @@ flip runReaderT settings $ action (curr_ix', tool, td, lr) >>= \case Left err -> liftIO $ putStrLn ("Error: " <> err) Right _ -> liftIO $ putStrLn "Success" - getAppData Nothing >>= \case + getAppData Nothing (view appSettings as) >>= \case Right data' -> do putStrLn "Press enter to continue" _ <- getLine @@ -212,7 +213,7 @@ flip runReaderT settings $ action (curr_ix, tool, td, lr) >>= \case Left err -> liftIO $ putStrLn ("Error: " <> err) Right _ -> liftIO $ putStrLn "Success" - getAppData Nothing >>= \case + getAppData Nothing (view appSettings as) >>= \case Right data' -> do putStrLn "Press enter to continue" _ <- getLine @@ -550,6 +551,7 @@ (compopts ^. CompileGHC.buildSystem) (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir) (fmap (words . T.unpack) $ compopts ^. CompileGHC.installTargets) + (compopts ^. CompileGHC.docs) AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask let vi2 = getVersionMetadata targetVer ghc dls2 when @@ -711,14 +713,15 @@ getAppData :: Maybe GHCupInfo + -> BrickSettings -> IO (Either String BrickData) -getAppData mgi = runExceptT $ do +getAppData mgi BrickSettings{..} = runExceptT $ do r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) settings <- liftIO $ readIORef settings' r' <- lift $ flip runReaderT settings $ runE $ do - lV <- listVersions Nothing [] ShowUpdates False True (Nothing, Nothing) + lV <- listVersions bsTool bsCriteria bsShowRevisions bsHideOld bsShowNightly (bsFrom, bsTo) pure $ BrickData lV ExceptT $ pure $ either (Left . prettyHFError) Right $ veitherToEither r' @@ -736,8 +739,8 @@ withIOActionRecommended $ installWithOptions (AdvancedInstall.InstallOptions Nothing True Nothing Nothing False [] Nothing)) , ( bShowAllVersions , Just $ \BrickSettings {..} -> - if _showAllVersions then "Don't show all versions" else "Show all versions" - , hideShowHandler' (not . _showAllVersions) + if not bsHideOld then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . Common._showAllVersions) ) , (bHelp, Just $ const "help", mode .= KeyInfo) , (KeyCombination Vty.KEnter [], Just $ const "Show tool details", mode .= Common.ToolInfo ) @@ -760,8 +763,8 @@ , (bChangelog, Just $ const "ChangeLog", withIOAction changelog') , ( bShowAllVersions , Just $ \BrickSettings {..} -> - if _showAllVersions then "Don't show all versions" else "Show all versions" - , hideShowHandler' (not . _showAllVersions) + if not bsHideOld then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . Common._showAllVersions) ) , (bHelp, Just $ const "Help", mode .= KeyInfo) , (KeyCombination Vty.KEnter [], Just $ const "Advanced options", createMenuforTool ) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -103,7 +103,7 @@ $ if st ^. versionFocus then Actions.keyHandlersVersionList (st ^. appKeys) else Actions.keyHandlersToolList (st ^. appKeys) - navg = Navigation.draw (st ^. versionFocus) dimAttrs (st ^. appState) <=> footer + navg = Navigation.draw (st ^. versionFocus) dimAttrs (st ^. appSettings ) (st ^. appState) <=> footer in case st ^. mode of Navigation -> [navg] Tutorial -> [Tutorial.draw (bQuit $ st ^. appKeys), navg] diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -34,9 +34,16 @@ frontwardLayer, enableScreenReader, zoom, - defaultAppSettings, lr, showAllVersions, + _showAllVersions, + bsToolL, + bsCriteriaL, + bsFromL, + bsToL, + bsHideOldL, + bsShowNightlyL, + bsShowRevisionsL, Name(..), Mode(..), BrickData(..), @@ -49,15 +56,17 @@ , CompileGHCButton, CompileHLSButton, CabalProjectEditBox , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox, GHCInstallTargets + , DocsEditBox ) ) where -import GHCup.Command.List ( ToolListResult ) +import GHCup.Command.List ( ToolListResult, ListCriteria ) import GHCup.Prelude ( isWindows ) -import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) +import GHCup.Types ( Tool, KeyCombination (KeyCombination), ShowRevisions, ShowNightly(..) ) import Data.List (intercalate) import Prelude hiding ( appendFile ) import qualified Graphics.Vty as Vty -import Optics.TH (makeLenses) +import Optics (Lens', lens) +import Optics.TH (makeLenses, makeLensesFor) import Optics.Lens (toLensVL) import qualified Brick import qualified Brick.Widgets.Border as Border @@ -65,6 +74,7 @@ import qualified Data.Text as T import qualified Brick.Widgets.Center as Brick import qualified Brick.Widgets.Border.Style as Border +import Data.Time.Calendar (Day) -- We could use regular ADTs but different menus share the same options. -- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc... @@ -139,6 +149,9 @@ pattern GHCInstallTargets :: ResourceId pattern GHCInstallTargets = ResourceId 24 +pattern DocsEditBox :: ResourceId +pattern DocsEditBox = ResourceId 25 + -- | Name data type. Uniquely identifies each widget in the TUI. -- some constructors might end up unused, but still is a good practise -- to have all of them defined, just in case @@ -229,10 +242,34 @@ makeLenses ''BrickData -data BrickSettings = BrickSettings { _showAllVersions :: Bool} +-- Currently the only TUI 'toggable' setting is ioHideOldL... all the +-- other fiels are only used in 'getAppData'. If you want to make +-- them toggable as well, they have to be utilized in 'constructList'. +data BrickSettings = BrickSettings { + bsTool :: Maybe [Tool] + , bsCriteria :: [ListCriteria] + , bsFrom :: Maybe Day + , bsTo :: Maybe Day + , bsHideOld :: Bool + , bsShowNightly :: ShowNightly + , bsShowRevisions :: ShowRevisions + } --deriving Show -makeLenses ''BrickSettings +makeLensesFor + [ ("bsTool", "bsToolL") + , ("bsCriteria", "bsCriteriaL") + , ("bsFrom", "bsFromL") + , ("bsTo", "bsToL") + , ("bsHideOld", "bsHideOldL") + , ("bsShowNightly", "bsShowNightlyL") + , ("bsShowRevisions", "bsShowRevisionsL") + ] + ''BrickSettings -defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings False +showAllVersions :: Lens' BrickSettings Bool +showAllVersions = lens (not . bsHideOld) (\BrickSettings{..} showAll -> let bsHideOld = not showAll in BrickSettings{..}) + +_showAllVersions :: BrickSettings -> Bool +_showAllVersions = not . bsHideOld + diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -30,6 +30,7 @@ setCompile, overwriteVer, buildFlavour, + docs, buildSystem, isolateDir, gitRef, @@ -75,6 +76,7 @@ , _setCompile :: Bool , _overwriteVer :: Maybe [VersionPattern] , _buildFlavour :: Maybe String + , _docs :: Maybe String , _buildSystem :: Maybe BuildSystem , _isolateDir :: Maybe FilePath , _gitRef :: Maybe String @@ -105,6 +107,7 @@ Nothing Nothing initialInstallTargets + Nothing validator CompileGHCOptions {..} = case (_setCompile, _isolateDir) of (True, Just _) -> Just "Cannot set active when doing an isolated install" _ -> case (_buildConfig, _buildSystem) of @@ -206,6 +209,9 @@ , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour & Menu.fieldLabelL .~ "flavour" & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" + , Menu.createEditableField (Common.MenuElement Common.DocsEditBox) (Right . Just . T.unpack) docs + & Menu.fieldLabelL .~ "docs" + & Menu.fieldHelpMsgL .~ "Disable some or all of the docs (e.g. 'none' or 'no-sphinx')" , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs & Menu.fieldLabelL .~ "CONFIGURE_ARGS" & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure" diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs --- a/lib-tui/GHCup/Brick/Widgets/Navigation.hs +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -20,7 +20,7 @@ tagToString, ToolDescription, isCompat, KeyBindings(..), - KeyCombination(..)) + KeyCombination(..), ShowRevisions(..)) import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Attributes as Attributes import Brick @@ -45,6 +45,7 @@ import Text.PrettyPrint.HughesPJClass (prettyShow) import Control.Monad.State.Class (get, modify) import qualified Graphics.Vty as Vty +import GHCup.Brick.Common (BrickSettings (..)) type BrickList = L.GenericList Common.Name V.Vector @@ -81,8 +82,8 @@ -- | How to draw the navigation widget -draw :: Bool -> AttrMap -> BrickInternalState -> Widget Common.Name -draw versionFocus dimAttrs bis +draw :: Bool -> AttrMap -> BrickSettings -> BrickInternalState -> Widget Common.Name +draw versionFocus dimAttrs BrickSettings{..} bis = Brick.padBottom Max ( Brick.joinBorders $ Brick.withBorderStyle unicode $ borderWithLabel (Brick.str "GHCup") @@ -127,9 +128,15 @@ | lInstalled -> (Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign) | otherwise -> (Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign) rev = case lRev of - (rev', RevUpdate) -> "-r" <> show rev' - (rev', RevOutdated) -> "-r" <> show rev' - (_, RevNormal) -> "" + (rev', RevUpdate) + | bsShowRevisions == ShowNone -> "" + | otherwise -> "-r" <> show rev' + (rev', RevOutdated) + | bsShowRevisions == ShowNone -> "" + | otherwise -> "-r" <> show rev' + (rev', RevNormal) + | bsShowRevisions == ShowAll -> "-r" <> show rev' + | otherwise -> "" ver = case lCross of Nothing -> T.unpack (prettyVer lVer) <> rev Just c -> T.unpack (c <> "-" <> prettyVer lVer) <> rev diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -15,6 +15,7 @@ module GHCup.BrickMain where +import GHCup.OptParse.TUI (InteractiveOptions (..)) import GHCup.Command.List ( ListResult (..)) import GHCup.Types ( Settings(noColor), @@ -42,18 +43,29 @@ import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS import Data.Maybe (isNothing) import qualified Data.Map.Strict as M +import GHCup.Brick.Common (BrickSettings(..)) brickMain :: AppState + -> InteractiveOptions -> IO () -brickMain s = do +brickMain s InteractiveOptions{..} = do writeIORef Actions.settings' s + let brickSettings = BrickSettings { + bsTool = ioTool + , bsCriteria = ioCriteria + , bsFrom = ioFrom + , bsTo = ioTo + , bsHideOld = ioHideOld + , bsShowNightly = ioShowNightly + , bsShowRevisions = ioShowRevisions + } - eAppData <- Actions.getAppData (Just $ ghcupInfo s) + eAppData <- Actions.getAppData (Just $ ghcupInfo s) brickSettings case eAppData of Right ad -> do - let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing + let initial_list = Actions.constructList ad brickSettings Nothing current_element = L.listSelectedElement initial_list exit_key = let KeyBindings {..} = keyBindings s @@ -77,7 +89,7 @@ pure $ filter (\(ListResult {..}) -> lInstalled && isNothing lCross) lr' initstate = AppState.BrickState ad - Common.defaultAppSettings + brickSettings initial_list (ContextMenu.create (t, (td, lr)) exit_key) (AdvancedInstall.create exit_key) diff --git a/lib/GHCup/Command/Compile/GHC.hs b/lib/GHCup/Command/Compile/GHC.hs --- a/lib/GHCup/Command/Compile/GHC.hs +++ b/lib/GHCup/Command/Compile/GHC.hs @@ -172,6 +172,7 @@ -> Maybe BuildSystem -> InstallDir -> Maybe [String] + -> Maybe String -> Excepts '[ AlreadyInstalled , BuildFailed @@ -201,10 +202,11 @@ , ParseError , NoInstallInfo , MalformedInstallInfo + , NotFoundInPATH ] m TargetVersion -compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir installTargets +compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir installTargets docs = do pfreq@PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -235,7 +237,7 @@ Just vps' -> fmap Just $ expandVersionPattern (Just ver) "" "" "" "" vps' Nothing -> pure Nothing - pure (workdir, tmpUnpack, Just (TargetVersion crossTarget ver), ov) + pure (workdir, tmpUnpack, TargetVersion crossTarget ver, ov) RemoteDist uri -> do lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri) @@ -244,7 +246,7 @@ tmpDownload <- lift withGHCupTmpDir tmpUnpack <- lift mkGhcupTmpDir tar <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpDownload) Nothing False - (bf, ver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do + (bf, ver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError, NotFoundInPATH, ParseError] tmpUnpack $ do liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar let regex = [s|^(.*/)*boot$|] :: B.ByteString [bootFile] <- liftIO $ findFilesDeep @@ -253,24 +255,23 @@ execBlank regex ) - ver <- liftE $ catchAllE @_ @'[ProcessError, ParseError, NotFoundInPATH] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer - (appendGHCupPath tmpUnpack (takeDirectory bootFile)) + ver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile)) pure (bootFile, ver) let workdir = appendGHCupPath tmpUnpack (takeDirectory bf) ov <- case vps of - Just vps' -> fmap Just $ expandVersionPattern ver "" "" "" "" vps' + Just vps' -> fmap Just $ expandVersionPattern (Just ver) "" "" "" "" vps' Nothing -> pure Nothing - let tver = TargetVersion crossTarget <$> ver + let tver = TargetVersion crossTarget ver pure (workdir, tmpUnpack, tver, ov) -- clone from git GitDist GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - (ver, ov) <- cleanUpOnError tmpUnpack $ reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do + (ver, ov) <- cleanUpOnError tmpUnpack $ reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError, ParseError] 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" ] @@ -280,7 +281,7 @@ , fromString rep ] -- figure out if we can do a shallow clone - remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure []) + remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError, ParseError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError, ParseError] (\(_ :: ProcessError) -> pure []) $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack) let shallow_clone | isCommitHash ref = True @@ -311,18 +312,17 @@ liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) -- bootstrap - ver <- liftE $ catchAllE @_ @'[ProcessError, ParseError, NotFoundInPATH] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer - tmpUnpack + ver <- liftE $ getGHCVer tmpUnpack liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> - "GHC version (from Makefile): " <> T.pack (show (prettyVer <$> ver)) <> + "GHC version (from Makefile): " <> prettyVer ver <> (if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <> (if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash) liftIO $ threadDelay 5000000 -- give the user a sec to intervene ov <- case vps of Just vps' -> fmap Just $ expandVersionPattern - ver + (Just ver) (take 7 $ T.unpack chash) (T.unpack chash) (maybe "" T.unpack git_describe) @@ -332,13 +332,12 @@ pure (ver, ov) - let tver = TargetVersion crossTarget <$> ver + let tver = TargetVersion crossTarget ver pure (tmpUnpack, tmpUnpack, 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 (TargetVersion crossTarget ov') - | Just tver' <- tver -> pure tver' - | otherwise -> fail "No GHC version given and couldn't detect version. Giving up..." + | otherwise -> pure tver let rev = fromMaybe 0 $ preview (_GHCupDownloads % ix ghc % toolVersionsL % ix installVer % revisionSpecL % mapLast % _1) dls @@ -362,10 +361,8 @@ mBindist <- liftE $ runBuildAction tmpUnpack (do - -- prefer 'tver', because the real version carries out compatibility checks - -- we don't want the user to do funny things with it - let doHadrian = Just <$> compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir - doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir + let doHadrian = Just <$> compileHadrianBindist tver (fromGHCupPath workdir) ghcdir + doMake = compileMakeBindist tver (fromGHCupPath workdir) ghcdir case buildSystem of Just Hadrian -> do lift $ logInfo "Requested to use Hadrian" @@ -400,7 +397,7 @@ let trev = TargetVersionRev installVer rev case mBindist of Just bindist -> do - spec <- liftE $ compileInstallSpec bindist installVer + spec <- liftE $ compileInstallSpec bindist installVer tver cSize <- liftIO $ getFileSize bindist cDigest <- liftIO $ getFileDigest bindist liftE $ void $ installPackedBindist ghc toolDesc bindist @@ -421,7 +418,7 @@ -- for old Make cross installations we don't get a bindist, -- so this needs to be done manually Nothing -> do - spec <- liftE $ compileInstallSpec' (fromInstallDir ghcdir "bin") installVer + spec <- liftE $ compileInstallSpec' (fromInstallDir ghcdir "bin") installVer tver let dlInfo = (DownloadInfo { _dlUri = "" , _dlSubdir = Just $ RegexDir "ghc-.*" @@ -454,17 +451,18 @@ , HasPlatformReq env ) => FilePath -- ^ Binary dir - -> TargetVersion + -> TargetVersion -- ^ user requested version + -> TargetVersion -- ^ original version -> Excepts '[ UnknownArchive , ArchiveResult ] m InstallationSpecResolved - compileInstallSpec' bindir installVer = do + compileInstallSpec' bindir installVer origVer = do pfreq <- lift getPlatformReq - let pred' f = not (null f) && not (prettyVer (_tvVersion installVer) `T.isSuffixOf` T.pack f) + let pred' f = not (null f) && not (prettyVer (_tvVersion origVer) `T.isSuffixOf` T.pack f) files <- liftIO $ listDirectoryFiles bindir let binaries = filter pred' . fmap takeFileName $ files -- ghcup whereis picks the first binary, so we need to ensure 'ghc' is at the front - binariesSorted = nub (maybe id (\(T.unpack -> t) a -> t <> "-" <> a) (_tvTarget installVer) "ghc" <.> exeExt:binaries) + binariesSorted = nub (maybe id (\(T.unpack -> t) a -> t <> "-" <> a) (_tvTarget origVer) "ghc" <.> exeExt:binaries) pure $ (defaultGHCInstallSpec pfreq installVer) { _isExeSymLinked = syml binariesSorted } where syml binaries = @@ -481,17 +479,18 @@ , HasPlatformReq env ) => FilePath -- ^ archive path - -> TargetVersion + -> TargetVersion -- ^ user requested version + -> TargetVersion -- ^ original version -> Excepts '[ UnknownArchive , ArchiveResult ] m InstallationSpecResolved - compileInstallSpec tarball installVer = do + compileInstallSpec tarball installVer origVer = do pfreq <- lift getPlatformReq archiveFiles <- liftE $ getArchiveFiles tarball - let pred' f = not (null f) && not (prettyVer (_tvVersion installVer) `T.isSuffixOf` T.pack f) + let pred' f = not (null f) && not (prettyVer (_tvVersion origVer) `T.isSuffixOf` T.pack f) let binaries = filter pred' . fmap takeFileName . filter ("*/bin/*" ?==) $ archiveFiles -- ghcup whereis picks the first binary, so we need to ensure 'ghc' is at the front - binariesSorted = nub (maybe id (\(T.unpack -> t) a -> t <> "-" <> a) (_tvTarget installVer) "ghc" <.> exeExt:binaries) + binariesSorted = nub (maybe id (\(T.unpack -> t) a -> t <> "-" <> a) (_tvTarget origVer) "ghc" <.> exeExt:binaries) pure $ (defaultGHCInstallSpec pfreq installVer) { _isExeSymLinked = syml binariesSorted } where syml binaries = @@ -570,6 +569,7 @@ liftE $ execWithWrapper hadrian_build ( maybe [] (\j -> ["-j" <> show j] ) jobs ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour + ++ maybe [] (\d -> ["--docs=" <> d]) docs ++ ["binary-dist"] ) (Just workdir) "ghc-make" diff --git a/lib/GHCup/Command/GC.hs b/lib/GHCup/Command/GC.hs --- a/lib/GHCup/Command/GC.hs +++ b/lib/GHCup/Command/GC.hs @@ -86,7 +86,7 @@ ) => Excepts '[NotInstalled, UninstallFailed, ParseError, MalformedInstallInfo] m () rmUnsetTools = do - vers <- liftE $ listVersions Nothing [ListInstalled True, ListSet False] ShowUpdates False True (Nothing, Nothing) + vers <- liftE $ listVersions Nothing [ListInstalled True, ListSet False] ShowUpdates False NShowAll (Nothing, Nothing) iforM_ vers $ \tool (_, ls) -> forM_ ls $ \ListResult{..} -> liftE $ rmToolVersion tool (TargetVersion lCross lVer) diff --git a/lib/GHCup/Command/Install/LowLevel.hs b/lib/GHCup/Command/Install/LowLevel.hs --- a/lib/GHCup/Command/Install/LowLevel.hs +++ b/lib/GHCup/Command/Install/LowLevel.hs @@ -8,6 +8,7 @@ module GHCup.Command.Install.LowLevel where import GHCup.Errors +import GHCup.Input.Parsers.Domain import GHCup.Input.SymlinkSpec import GHCup.Prelude import GHCup.Prelude.Process @@ -17,6 +18,7 @@ import GHCup.System.Cmd import GHCup.System.Directory import GHCup.Types +import GHCup.Types.JSON (safePath, safeFilename) import GHCup.Types.Optics import Control.Applicative @@ -30,12 +32,12 @@ import Data.Maybe import Data.Variant.Excepts import Data.Versions hiding ( patch ) -import Data.Void import Prelude hiding ( abs ) import System.FilePath import System.FilePattern.Directory import qualified Data.ByteString as B +import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified System.FilePath.Posix as Posix import qualified Text.Megaparsec as MP @@ -107,9 +109,9 @@ addConfArgs <- lift $ sanitizefConfOptions extraArgs let configFile = fromMaybe "configure" _csConfigFile - processedConfArgs <- forM _csConfigArgs $ \a -> throwOnParseError . parseDomain $ a + processedConfArgs <- forM _csConfigArgs $ \a -> liftE $ throwOnParseError . parseDomain $ a newEnv <- forM _csConfigEnv $ \EnvSpec{..} -> do - processedEnv <- throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val) + processedEnv <- liftE $ throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val) liftIO (augmentEnvironment processedEnv _esUnion) liftE $ execWithWrapper "sh" (("." Posix. configFile) : processedConfArgs <> addConfArgs @@ -125,15 +127,15 @@ processedMakeArgs <- case installTargets of Just it -> do -- we need to check whether applying 'installTargets' would wipe out PREFIX/DESTDIR - origArgs <- throwOnParseError $ forM _msMakeArgs parseDomain + origArgs <- liftE $ throwOnParseError $ forM _msMakeArgs parseDomain if origArgs /= _msMakeArgs then throwE $ InvalidBuildConfig $ "Can't overwrite install targets " <> T.pack (show _msMakeArgs) <> " since they contain domain variables." - else throwOnParseError $ forM it parseDomain + else liftE $ throwOnParseError $ forM it parseDomain Nothing -> - throwOnParseError $ forM _msMakeArgs parseDomain + liftE $ throwOnParseError $ forM _msMakeArgs parseDomain newEnv <- forM _msMakeEnv $ \EnvSpec{..} -> do - processedEnv <- throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val) + processedEnv <- liftE $ throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val) liftIO (augmentEnvironment processedEnv _esUnion) liftE $ makeWithWrapper processedMakeArgs (Just workdir) "make" newEnv _ -> pure () @@ -162,22 +164,14 @@ destDir = fromGHCupPath tmpInstallDest dropDrive (fromInstallDir installDest) into = destDir fromMaybe source destFile liftIO $ createDirRecursive' (takeDirectory into) - copyFileE from into (not forceInstall) + handleIO (throwE . CopyError . show) . liftIO . install from into $ not forceInstall logDebug $ "cp " <> (if forceInstall then "-f " else "") <> T.pack from <> " " <> T.pack into pure into - parseDomain = MP.parse domainParser "" - - throwOnParseError = either (throwE . ParseError . show) pure - - domainParser :: MP.Parsec Void String String - domainParser = concat <$> many anyOrKnownVars - where - -- TODO: make this more efficient - anyOrKnownVars :: MP.Parsec Void String String - anyOrKnownVars = MP.try (fmap (const (fromInstallDir installDest)) (MP.chunk "${PREFIX}")) - <|> MP.try (fmap (const (fromGHCupPath tmpInstallDest)) (MP.chunk "${TMPDIR}")) - <|> fmap (:[]) MP.anySingle + env = M.fromList [(PREFIX, fromInstallDir installDest) + ,(TMPDIR, fromGHCupPath tmpInstallDest) + ] + parseDomain = MP.parse (domainParser env) "installTheSpec" makeWithWrapper :: ( MonadIOish m @@ -279,6 +273,7 @@ symlinkBinaries (IsolateDirResolved _) _ _ _ _ = pure () symlinkBinaries (fromInstallDir -> toolDir) rawSpec bindir tool tver = do let spec = substituteSpec <$> rawSpec + forM_ spec safeSpec pvpSyms <- lift $ getPVPSymlinks' (fromInstallDir bindir) spec toolDir forM_ pvpSyms $ lift . uncurry createLink case bindir of @@ -286,6 +281,15 @@ GHCupDir d -> linkMajor (fromGHCupPath d) GHCupBinDir d -> whenM (lift isLatest) $ linkMajor d where + safeSpec SymlinkSpec{..} = do + checkSafePath _slTarget + checkSafeFilename _slLinkName + forM_ _slSetName checkSafeFilename + + checkSafePath fp = unless (safePath fp) $ throwE (MalformedInstallInfo "'..' or '.' are not allowed") + + checkSafeFilename fp = unless (safeFilename fp) $ throwE (MalformedInstallInfo "'..' or '.' are not allowed and filepath must have no path separators") + linkMajor d = do let ver = _tvVersion tver pvpMajorSyms <- liftE $ getPVPMajorSymlinks' d rawSpec ver toolDir diff --git a/lib/GHCup/Command/List.hs b/lib/GHCup/Command/List.hs --- a/lib/GHCup/Command/List.hs +++ b/lib/GHCup/Command/List.hs @@ -125,7 +125,7 @@ -> [ListCriteria] -> ShowRevisions -> Bool - -> Bool + -> ShowNightly -> (Maybe Day, Maybe Day) -> Excepts '[ParseError] m ToolListResult listVersions lt' criteria showRevisions hideOld showNightly days = do @@ -140,8 +140,15 @@ Just VersionRev{..} -> do getHLSGHCs _vrVersion Nothing -> pure [] - pure $ listVersions' dls pfreq instTools hlsGHCs lt' criteria showRevisions hideOld showNightly days + pure $ listVersions' dls pfreq (filterTools lt' instTools) hlsGHCs lt' criteria showRevisions hideOld showNightly days +filterTools :: + Maybe [Tool] + -> Map.Map Tool (Map.Map (Maybe Text) ([VersionRev], Maybe VersionRev)) + -> Map.Map Tool (Map.Map (Maybe Text) ([VersionRev], Maybe VersionRev)) +filterTools Nothing tools = tools +filterTools (Just lt') tools = M.filterWithKey (\k _ -> k `elem` lt') tools + listVersions' :: GHCupDownloads -> PlatformRequest @@ -151,7 +158,7 @@ -> [ListCriteria] -> ShowRevisions -> Bool - -> Bool + -> ShowNightly -> (Maybe Day, Maybe Day) -> ToolListResult listVersions' dls pfreq instTools hlsGHCs lt' criteria showRevisions hideOld showNightly days = @@ -360,9 +367,14 @@ | otherwise = Just lr filterNightly :: ListResult -> Maybe ListResult - filterNightly lr@ListResult {..} - | showNightly = Just lr - | otherwise = if lInstalled || (Nightly `notElem` lTag && LatestNightly `notElem` lTag) - then Just lr - else Nothing + filterNightly lr@ListResult {..} = case showNightly of + NShowAll -> Just lr + NShowLatest -> if | lInstalled -> Just lr + | LatestNightly `elem` lTag -> Just lr + | Nightly `elem` lTag -> Nothing + | otherwise -> Just lr + NShowNone -> if | lInstalled -> Just lr + | LatestNightly `elem` lTag -> Nothing + | Nightly `elem` lTag -> Nothing + | otherwise -> Just lr diff --git a/lib/GHCup/Input/Parsers.hs b/lib/GHCup/Input/Parsers.hs --- a/lib/GHCup/Input/Parsers.hs +++ b/lib/GHCup/Input/Parsers.hs @@ -271,6 +271,13 @@ | otherwise = Left ("Unknown criteria: " <> s') where t = T.toLower (T.pack s') +nightlyShowParser :: String -> Either String ShowNightly +nightlyShowParser s' | t == T.pack "latest" = Right NShowLatest + | t == T.pack "all" = Right NShowAll + | t == T.pack "none" = Right NShowNone + | otherwise = Left ("Unknown criteria: " <> s') + where t = T.toLower (T.pack s') + criteriaParser :: String -> Either String ListCriteria criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True | t == T.pack "set" = Right $ ListSet True diff --git a/lib/GHCup/Input/Parsers/Domain.hs b/lib/GHCup/Input/Parsers/Domain.hs new file mode 100644 --- /dev/null +++ b/lib/GHCup/Input/Parsers/Domain.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module : GHCup.Input.Parsers.Domain +Description : Domain parsers and bashism features for the metadata +Copyright : (c) Julian Ospald, 2026 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Input.Parsers.Domain where + +import GHCup.Types +import GHCup.Errors + +import Data.Bifunctor (bimap) +import Data.Versions ( Version, version ) +import Control.Applicative ( Alternative ((<|>), many) ) +import Data.Maybe +import Data.Void +import Text.Regex.Posix +import Data.Variant.Excepts + +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Text.Megaparsec as MP + + +evalDomainVal :: M.Map DomainVariable String -> (DomainVariable, Maybe Substitution) -> Maybe String +evalDomainVal env (dvar, msubst) = do + var <- M.lookup dvar env + pure $ maybe var (substitute var) msubst + where + mkRegex = makeRegexOpts compBlank execBlank + stripSuffix (T.pack -> suff) (T.pack -> t) = fmap T.unpack $ T.stripSuffix suff t + stripPrefix (T.pack -> prev) (T.pack -> t) = fmap T.unpack $ T.stripPrefix prev t + breakOn (T.pack -> needle) (T.pack -> haystack) = bimap T.unpack T.unpack $ T.breakOn needle haystack + replace (T.pack -> needle) (T.pack -> replacement) (T.pack -> haystack) = T.unpack $ T.replace needle replacement haystack + + substitute var (Replace needle replacement) + | null matchedNeedle = var + | otherwise = + let (pre, rest) = breakOn matchedNeedle var + in case stripPrefix matchedNeedle rest of + Nothing -> var + Just rest' -> pre <> replacement <> rest' + where + matchedNeedle = match (mkRegex (globToRegex needle)) var + substitute var (ReplaceAll needle replacement) + | null matchedNeedle = var + | otherwise = replace matchedNeedle replacement var + where + matchedNeedle = match (mkRegex (globToRegex needle)) var + substitute var (StripPrefix prefix) + = let matchedPrefix = match (mkRegex ("^" <> globToRegex prefix)) var + in fromMaybe var (stripPrefix matchedPrefix var) + substitute var (StripSuffix suffix) + = let matchedSuffix = match (mkRegex (globToRegex suffix <> "$")) var + in fromMaybe var (stripSuffix matchedSuffix var) + +-- https://www.man7.org/linux/man-pages/man7/glob.7.html +globToRegex :: String -> String +globToRegex = go + where + go :: String -> String + go ('\\':'*':xs) = '\\' : '*' : go xs + go ('\\':'?':xs) = '?' : go xs + go ('*':xs) = '.' : '*' : go xs + go ('?':xs) = '.' : go xs + go ('[':'!':']':xs) = '\\' : '[' : '!' : ']' : go xs + go ('[':'!':xs) = '[' : '^' : charClass xs + go ('[':']':xs) = '[' : '\\' : ']' : charClass xs + go ('[':xs) = '[' : charClass xs + go (x:xs) + | x `elem` specialChars = '\\' : x : go xs + | otherwise = x : go xs + go [] = [] + + charClass :: String -> String + charClass ('\\':']':xs) = '\\' : ']' : charClass xs + charClass (']':xs) = ']' : go xs + charClass (x:xs) + | x `elem` specialChars = '\\' : x : charClass xs + | otherwise = x : charClass xs + charClass [] = [] + + -- https://stackoverflow.com/a/400316 + specialChars :: String + specialChars = ".^$*[\\" + +domainParserP :: MP.Parsec Void String (DomainVariable, Maybe Substitution) +domainParserP = (,) <$> (MP.chunk "${" *> var) <*> MP.optional (MP.try subst) <* MP.chunk "}" + where + subst = MP.try replaceP <|> MP.try replaceAllP <|> MP.try stripSuffixP <|> MP.try stripPrefixP + replaceP = Replace <$> (MP.chunk "/" *> MP.some escaped <* MP.chunk "/") <*> MP.many escaped + replaceAllP = ReplaceAll <$> (MP.chunk "//" *> MP.some escaped <* MP.chunk "/") <*> MP.many escaped + stripPrefixP = StripPrefix <$> (MP.chunk "#" *> MP.some escaped) + stripSuffixP = StripSuffix <$> (MP.chunk "%" *> MP.some escaped) + escaped :: MP.Parsec Void String Char + escaped = do + t <- MP.lookAhead MP.anySingle + if | t == '\\' + -> MP.chunk "\\" *> MP.anySingle + | otherwise + -> MP.noneOf ("/%#}{$" :: String) + + var = (TARGETFN <$ MP.try (MP.chunk "TARGETFN")) + <|> (PKGVER <$ MP.try (MP.chunk "PKGVER")) + <|> (PREFIX <$ MP.try (MP.chunk "PREFIX")) + <|> (TMPDIR <$ MP.try (MP.chunk "TMPDIR")) + + + +throwOnParseError :: (Monad m, Show a) => Either a b -> Excepts '[ParseError] m b +throwOnParseError = either (throwE . ParseError . show) pure + +domainParser :: M.Map DomainVariable String -> MP.Parsec Void String String +domainParser env = domainParser' env [] + +domainParser' :: M.Map DomainVariable String -> [DomainVariable] -> MP.Parsec Void String String +domainParser' env skip = concat <$> many anyOrKnownVars + where + anyOrKnownVars :: MP.Parsec Void String String + anyOrKnownVars = do + (MP.try (Just <$> MP.lookAhead ((,,) <$> MP.anySingle <*> MP.anySingle <*> MP.anySingle)) <|> pure Nothing) >>= \case + Just ('\\', '$', '{') -> do + _ <- MP.anySingle + fmap (:[]) MP.anySingle + Just ('$', '{', _) -> do + (matched, r@(dvar, _)) <- MP.match domainParserP + case evalDomainVal env r of + Just x -> pure x + Nothing + | dvar `elem` skip -> pure matched + | otherwise -> fail $ "Variable " <> show dvar <> " not found in env" + _ -> fmap (:[]) MP.anySingle + +domainParserVer :: M.Map DomainVariable String -> MP.Parsec Void String [Either Char Version] +domainParserVer env = many anyOrKnownVars + where + anyOrKnownVars :: MP.Parsec Void String (Either Char Version) + anyOrKnownVars = do + (MP.try (Just <$> MP.lookAhead ((,,) <$> MP.anySingle <*> MP.anySingle <*> MP.anySingle)) <|> pure Nothing) >>= \case + Just ('\\', '$', '{') -> do + _ <- MP.anySingle + fmap Left MP.anySingle + Just ('$', '{', _) -> do + r <- domainParserP + v <- maybe (fail "Variable not found in env") pure (evalDomainVal env r) + v' <- either (fail . show) pure $ version (T.pack v) + pure (Right v') + _ -> fmap Left MP.anySingle diff --git a/lib/GHCup/Input/SymlinkSpec.hs b/lib/GHCup/Input/SymlinkSpec.hs --- a/lib/GHCup/Input/SymlinkSpec.hs +++ b/lib/GHCup/Input/SymlinkSpec.hs @@ -5,21 +5,21 @@ module GHCup.Input.SymlinkSpec where import GHCup.Errors +import GHCup.Input.Parsers.Domain +import GHCup.Prelude.Logger import GHCup.Query.GHCupDirs import GHCup.Types import GHCup.Types.Optics -import GHCup.Prelude.Logger -import Control.Applicative ( Alternative (many), (<|>) ) import Control.Monad ( forM ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Reader ( MonadReader ) import Data.Variant.Excepts ( Excepts, throwE ) import Data.Versions ( Version, prettyVer ) -import Data.Void ( Void ) import System.FilePath ( takeFileName ) import System.FilePattern.Directory ( getDirectoryFilesIgnore ) +import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Text.Megaparsec as MP @@ -38,15 +38,10 @@ setName <- forM _slSetName $ either (throwE . ParseError . show) pure . parseDomain pure $ SymlinkSpec target linkName _slPVPMajorLinks setName where - parseDomain = MP.parse domainParser "" + parseDomain = MP.parse (domainParserVer env) "parseSymlinkSpec" + env = M.fromList [(PKGVER, T.unpack $ prettyVer ver) + ] - domainParser :: MP.Parsec Void String [Either Char Version] - domainParser = many anyOrKnownVars - where - -- TODO: make this more efficient - anyOrKnownVars :: MP.Parsec Void String (Either Char Version) - anyOrKnownVars = MP.try (fmap (const (Right ver)) (MP.chunk "${PKGVER}")) - <|> fmap Left MP.anySingle substituteSpec :: SymlinkSpec [Either Char Version] -> SymlinkFileSpec substituteSpec SymlinkSpec{..} = @@ -79,13 +74,8 @@ logDebug2 $ "Parsed slSetName: " <> T.pack (show _slSetName) pure SymlinkSpec{..} where - parseDomain targetFn = either (throwE . ParseError . show) pure . MP.parse (domainParser targetFn) "" - - domainParser :: FilePath -> MP.Parsec Void String String - domainParser targetFn = concat <$> many anyOrKnownVars - where - -- TODO: make this more efficient - anyOrKnownVars :: MP.Parsec Void String String - anyOrKnownVars = MP.try (fmap (const targetFn) (MP.chunk "${TARGETFN}")) - <|> fmap (:[]) MP.anySingle + parseDomain targetFn = throwOnParseError . MP.parse (domainParser' env [PKGVER]) "resolveSymlinkSpec" + where + env = M.fromList [(TARGETFN, targetFn) + ] diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs --- a/lib/GHCup/Prelude/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -14,7 +14,7 @@ import GHCup.Types -import Control.Applicative ( Alternative((<|>), many) ) +import Control.Applicative ( Alternative (many, (<|>)) ) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/lib/GHCup/Query/DB.hs b/lib/GHCup/Query/DB.hs --- a/lib/GHCup/Query/DB.hs +++ b/lib/GHCup/Query/DB.hs @@ -273,6 +273,7 @@ pure $ TargetVersionRev tv rev +-- | Might return more tools than requested. getAllInstalledTools :: ( MonadReader env m , HasGHCupInfo env diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} #if defined(DHALL) {-# LANGUAGE DeriveAnyClass #-} #endif @@ -32,6 +33,7 @@ where import {-# SOURCE #-} GHCup.Query.GHCupDirs ( GHCupPath, fromGHCupPath ) +import GHCup.Prelude.Version.QQ (vver) import GHCup.Types.Stack ( SetupInfo ) import GHCup.Types.Tar ( ArchiveResult (..) ) @@ -513,7 +515,7 @@ _isExeRules = [] , _isDataRules = [] , _isConfigure = Just ConfigSpec { - _csConfigArgs = ["--prefix=${PREFIX}"] + _csConfigArgs = ["--prefix=${PREFIX}"] <> ldOverride , _csConfigEnv = Nothing , _csConfigFile = Just "configure" } @@ -524,7 +526,14 @@ , _isPreserveMtimes = True , _isExeSymLinked = defaultGHCExeSymLinked pfreq tver (ghcBinaries pfreq tver) } + where + ldOverride + | _tvVersion tver >= [vver|8.2.2|] + = ["--disable-ld-override"] + | otherwise + = [] + ghcBinaries :: PlatformRequest -> TargetVersion -> [FilePath] ghcBinaries _pfreq _tver = ["ghc", "haddock", "hpc", "hsc2hs", "ghci", "ghc-pkg", "hp2ps", "runhaskell", "runghc"] @@ -1430,3 +1439,19 @@ | ShowNone deriving (Eq, Show) +data ShowNightly = NShowLatest + | NShowAll + | NShowNone + deriving (Eq, Show) + +data Substitution = Replace String String + | ReplaceAll String String + | StripPrefix String + | StripSuffix String + deriving (Eq, Show) + +data DomainVariable = TARGETFN + | PKGVER + | PREFIX + | TMPDIR + deriving (Eq, Show, Ord) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -424,9 +424,6 @@ _slLinkName <- o .: "linkName" _slPVPMajorLinks <- fromMaybe False <$> o .:? "pVPMajorLinks" _slSetName <- o .:? "setName" - checkSafePath _slTarget - checkSafeFilename _slLinkName - forM_ _slSetName checkSafeFilename pure SymlinkSpec{..} instance FromJSON SymlinkInputSpec where @@ -437,9 +434,6 @@ _slLinkName <- o .: "linkName" _slPVPMajorLinks <- o .:? "pVPMajorLinks" .!= False _slSetName <- o .:? "setName" - checkSafePath _slTarget - checkSafeFilename _slLinkName - forM_ _slSetName checkSafeFilename pure SymlinkInputSpec{..} Nothing -> do _slTargetPattern <- o .: "targetPattern" @@ -447,10 +441,6 @@ _slLinkName <- o .: "linkName" _slPVPMajorLinks <- o .:? "pVPMajorLinks" .!= False _slSetName <- o .:? "setName" - forM_ _slTargetPattern checkSafePath - forM_ _slTargetPatternIgnore checkSafePath - checkSafeFilename _slLinkName - forM_ _slSetName checkSafeFilename pure SymlinkPatternSpec{..} instance FromJSON InstallFileRule where diff --git a/scripts/bootstrap/bootstrap-haskell b/scripts/bootstrap/bootstrap-haskell --- a/scripts/bootstrap/bootstrap-haskell +++ b/scripts/bootstrap/bootstrap-haskell @@ -41,7 +41,7 @@ plat="$(uname -s)" arch=$(uname -m) -ghver="0.2.5.0" +ghver="0.2.6.0" : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}" export GHCUP_SKIP_UPDATE_CHECK=yes diff --git a/test/ghcup-test/GHCup/ParserSpec.hs b/test/ghcup-test/GHCup/ParserSpec.hs --- a/test/ghcup-test/GHCup/ParserSpec.hs +++ b/test/ghcup-test/GHCup/ParserSpec.hs @@ -9,14 +9,17 @@ import GHCup.Types import GHCup.Types.JSON () +import GHCup.Input.Parsers.Domain import Data.Either ( isLeft ) import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.Set as Set import Data.Versions -import qualified Text.Megaparsec as MP import Text.Megaparsec +import qualified Data.Map.Strict as M +import qualified Data.Set as Set +import qualified Text.Megaparsec as MP + import Test.Hspec spec :: Spec @@ -96,7 +99,71 @@ it "ghcLinkVersion" $ do MP.parse ghcLinkVersion "" "ghc-8.10.7" `shouldBe` Right ghc8107 + it "domainParserP" $ do + MP.parse domainParserP "" "${TARGETFN}" `shouldBe` Right (TARGETFN, Nothing) + MP.parse domainParserP "" "${TARGETFN//./}" `shouldBe` Right (TARGETFN, Just $ ReplaceAll "." "") + MP.parse domainParserP "" "${TARGETFN/foo/bar}" `shouldBe` Right (TARGETFN, Just $ Replace "foo" "bar") + MP.parse domainParserP "" "${TARGETFN/\\/foo/\\/bar}" `shouldBe` Right (TARGETFN, Just $ Replace "/foo" "/bar") + MP.parse domainParserP "" "${PKGVER#foo}" `shouldBe` Right (PKGVER, Just $ StripPrefix "foo") + MP.parse domainParserP "" "${PKGVER%bar}" `shouldBe` Right (PKGVER, Just $ StripSuffix "bar") + MP.parse domainParserP "" "${PKGVER%\\/bar}" `shouldBe` Right (PKGVER, Just $ StripSuffix "/bar") + MP.parse domainParserP "" "${PKGVER//./\\/..\\/}" `shouldBe` Right (PKGVER, Just $ ReplaceAll "." "/../") + + it "domainParser" $ do + MP.parse (domainParser $ ml (PKGVER, "1.2.3")) "" "haskell-language-server.exe" + `shouldBe` Right "haskell-language-server.exe" + MP.parse (domainParser $ ml (PKGVER, "1.2.3")) "" "haskell-language-server-${PKGVER//./}.exe" + `shouldBe` Right "haskell-language-server-123.exe" + MP.parse (domainParser $ ml (PKGVER, "1.2.3")) "" "haskell-language-server-${PKGVER/./..}.exe" + `shouldBe` Right "haskell-language-server-1..2.3.exe" + MP.parse (domainParser $ ml (PKGVER, "1.2.3")) "" "haskell-language-server-${PKGVER//./\\/..\\/}.exe" + `shouldBe` Right "haskell-language-server-1/../2/../3.exe" + MP.parse (domainParser $ ml' [(TARGETFN, "haskell-language-server-9.6.7.exe") + ,(PKGVER, "2.14.0.0") + ] + ) "" "${TARGETFN%.exe}~${PKGVER}.exe" + `shouldBe` Right "haskell-language-server-9.6.7~2.14.0.0.exe" + MP.parse (domainParser $ ml' [(TARGETFN, "haskell-language-server-9.6.7.exe") + ,(PKGVER, "2.14.0.0") + ] + ) "" "${TARGETFN%.*}~${PKGVER}.exe" + `shouldBe` Right "haskell-language-server-9~2.14.0.0.exe" + + it "globToRegex" $ do + globToRegex "foo/bar.ext" `shouldBe` "foo/bar\\.ext" + globToRegex "[][!]" `shouldBe` "[\\]\\[!]" + globToRegex "[!][!]" `shouldBe` "\\[!]\\[!]" + globToRegex "[abk*?]" `shouldBe` "[abk\\*?]" + globToRegex "foo/bar.ext" `shouldBe` "foo/bar\\.ext" + globToRegex "f?o/ba*.ext" `shouldBe` "f.o/ba.*\\.ext" + + it "evalDomainVal" $ do + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Nothing) `shouldBe` Just "1.2.3" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ Replace "." "") `shouldBe` Just "12.3" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ ReplaceAll "." "") `shouldBe` Just "123" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ Replace "." ",") `shouldBe` Just "1,2.3" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ ReplaceAll "." ",") `shouldBe` Just "1,2,3" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ Replace "l" "k") `shouldBe` Just "1.2.3" + evalDomainVal (ml (PKGVER, "1.2.3")) (PKGVER, Just $ ReplaceAll "l" "k") `shouldBe` Just "1.2.3" + + evalDomainVal (ml (TARGETFN, "1.2.3")) (PKGVER, Nothing) `shouldBe` Nothing + evalDomainVal (ml (TARGETFN, "1.2.3")) (PKGVER, Just $ Replace "." "") `shouldBe` Nothing + evalDomainVal (ml (TARGETFN, "1.2.3")) (PKGVER, Just $ ReplaceAll "." "") `shouldBe` Nothing + evalDomainVal (ml (TARGETFN, "1.2.3")) (PKGVER, Just $ Replace "." ",") `shouldBe` Nothing + evalDomainVal (ml (TARGETFN, "1.2.3")) (PKGVER, Just $ ReplaceAll "." ",") `shouldBe` Nothing + + evalDomainVal (ml (TARGETFN, "foo/bar.ext")) (TARGETFN, Nothing) `shouldBe` Just "foo/bar.ext" + evalDomainVal (ml (TARGETFN, "foo/bar.ext")) (TARGETFN, Just $ Replace ".ext" "") `shouldBe` Just "foo/bar" + evalDomainVal (ml (TARGETFN, "foo/bar.ext")) (TARGETFN, Just $ ReplaceAll ".ext" "") `shouldBe` Just "foo/bar" + evalDomainVal (ml (TARGETFN, "foo/bar.ext")) (TARGETFN, Just $ StripSuffix ".ext") `shouldBe` Just "foo/bar" + evalDomainVal (ml (TARGETFN, "foo/bar.ext")) (TARGETFN, Just $ StripPrefix "foo/") `shouldBe` Just "bar.ext" + evalDomainVal (ml (TARGETFN, "foo/bar.ext*")) (TARGETFN, Just $ Replace ".ext[abk*?]" "") `shouldBe` Just "foo/bar" + evalDomainVal (ml (TARGETFN, "foo/BaR.ext*")) (TARGETFN, Just $ Replace "[!.][B-D][a-b][A-R][.*?]" "bar") `shouldBe` Just "foobarext*" + evalDomainVal (ml (TARGETFN, "foo*bar.ext")) (TARGETFN, Just $ StripPrefix "foo\\*") `shouldBe` Just "bar.ext" + where + ml (a, b) = M.singleton a b + ml' = M.fromList hls2_13_0_0 = Right TargetVersion { _tvTarget = Nothing, _tvVersion = Version { diff --git a/test/optparse-test/CompileTest.hs b/test/optparse-test/CompileTest.hs --- a/test/optparse-test/CompileTest.hs +++ b/test/optparse-test/CompileTest.hs @@ -41,6 +41,7 @@ Nothing Nothing Nothing + Nothing mkDefaultHLSCompileOptions :: HLSVer -> [ToolVersion] -> HLSCompileOptions mkDefaultHLSCompileOptions target ghcs = diff --git a/test/optparse-test/ListTest.hs b/test/optparse-test/ListTest.hs --- a/test/optparse-test/ListTest.hs +++ b/test/optparse-test/ListTest.hs @@ -11,7 +11,7 @@ listTests = buildTestTree listParseWith ("list", listCheckList) defaultOptions :: ListOptions -defaultOptions = ListOptions Nothing [] Nothing Nothing False False False ShowUpdates +defaultOptions = ListOptions Nothing [] Nothing Nothing False NShowLatest False ShowUpdates listCheckList :: [(String, ListOptions)] listCheckList = @@ -35,8 +35,8 @@ defaultOptions{lFrom = Just $ read "2023-07-22", lTo = Just $ read "2023-07-22"}) , ("list -o", defaultOptions{lHideOld = True}) , ("list --hide-old", defaultOptions{lHideOld = True}) - , ("list -n", defaultOptions{lShowNightly = True}) - , ("list --show-nightly", defaultOptions{lShowNightly = True}) + , ("list -n", defaultOptions{lShowNightly = NShowAll}) + , ("list --show-nightly", defaultOptions{lShowNightly = NShowAll}) , ("list -r", defaultOptions{lRawFormat = True}) , ("list --raw-format", defaultOptions{lRawFormat = True}) ]