diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 59ed48c..ee965cc 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -44,6 +44,7 @@ import Data.Vector ( Vector import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) +import System.Environment import System.Exit import System.IO.Unsafe import URI.ByteString @@ -118,8 +119,8 @@ showKey (Vty.KDown) = "↓" showKey key = tail (show key) -ui :: BrickState -> Widget String -ui BrickState { appSettings = as@(BrickSettings {}), ..} +ui :: AttrMap -> BrickState -> Widget String +ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..} = ( padBottom Max $ ( withBorderStyle unicode $ borderWithLabel (str "GHCup") @@ -150,9 +151,9 @@ ui BrickState { appSettings = as@(BrickSettings {}), ..} ver = case lCross of Nothing -> T.unpack . prettyVer $ lVer Just c -> T.unpack (c <> "-" <> prettyVer lVer) - dim = if lNoBindist - then updateAttrMap (const dimAttributes) . withAttr "no-bindist" - else id + dim + | lNoBindist = updateAttrMap (const dimAttrs) . withAttr "no-bindist" + | otherwise = id hooray | elem Latest lTag && not lInstalled = withAttr "hooray" @@ -239,39 +240,49 @@ minHSize :: Int -> Widget n -> Widget n minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') -app :: App BrickState e String -app = App { appDraw = \st -> [ui st] - , appHandleEvent = eventHandler - , appStartEvent = return - , appAttrMap = const defaultAttributes - , appChooseCursor = neverShowCursor - } +app :: AttrMap -> AttrMap -> App BrickState e String +app attrs dimAttrs = + App { appDraw = \st -> [ui dimAttrs st] + , appHandleEvent = eventHandler + , appStartEvent = return + , appAttrMap = const attrs + , appChooseCursor = neverShowCursor + } -defaultAttributes :: AttrMap -defaultAttributes = attrMap +defaultAttributes :: Bool -> AttrMap +defaultAttributes no_color = attrMap Vty.defAttr - [ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue) - , ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red) - , ("set" , Vty.defAttr `Vty.withForeColor` Vty.green) - , ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green) - , ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green) - , ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green) - , ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow) - , ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red) - , ("compiled" , Vty.defAttr `Vty.withForeColor` Vty.blue) - , ("stray" , Vty.defAttr `Vty.withForeColor` Vty.blue) - , ("help" , Vty.defAttr `Vty.withStyle` Vty.italic) - , ("hooray" , Vty.defAttr `Vty.withForeColor` Vty.brightWhite) + [ ("active" , Vty.defAttr `withBackColor` Vty.blue) + , ("not-installed", Vty.defAttr `withForeColor` Vty.red) + , ("set" , Vty.defAttr `withForeColor` Vty.green) + , ("installed" , Vty.defAttr `withForeColor` Vty.green) + , ("recommended" , Vty.defAttr `withForeColor` Vty.green) + , ("hls-powered" , Vty.defAttr `withForeColor` Vty.green) + , ("latest" , Vty.defAttr `withForeColor` Vty.yellow) + , ("prerelease" , Vty.defAttr `withForeColor` Vty.red) + , ("compiled" , Vty.defAttr `withForeColor` Vty.blue) + , ("stray" , Vty.defAttr `withForeColor` Vty.blue) + , ("help" , Vty.defAttr `withStyle` Vty.italic) + , ("hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) ] + where + withForeColor | no_color = const + | otherwise = Vty.withForeColor + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor -dimAttributes :: AttrMap -dimAttributes = attrMap + withStyle = Vty.withStyle + +dimAttributes :: Bool -> AttrMap +dimAttributes no_color = attrMap (Vty.defAttr `Vty.withStyle` Vty.dim) - [ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue) + [ ("active" , Vty.defAttr `withBackColor` Vty.blue) , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) ] - + where + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState) eventHandler st@(BrickState {..}) ev = do @@ -520,11 +531,13 @@ brickMain s l av pfreq' = do writeIORef logger' l let runLogger = myLoggerT l + no_color <- isJust <$> lookupEnv "NO_COLOR" + eAppData <- getAppData (Just av) pfreq' case eAppData of Right ad -> defaultMain - app + (app (defaultAttributes no_color) (dimAttributes no_color)) (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2eb4818..5057498 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -59,7 +59,8 @@ import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text ) import Prelude hiding ( appendFile ) import Safe -import System.Console.Pretty +import System.Console.Pretty hiding ( color ) +import qualified System.Console.Pretty as Pretty import System.Environment import System.Exit import System.IO hiding ( appendFile ) @@ -1531,6 +1532,20 @@ printListResult raw lr = do -- https://gitlab.haskell.org/ghc/ghc/issues/8118 setLocaleEncoding utf8 + no_color <- isJust <$> lookupEnv "NO_COLOR" + + let + color | raw || no_color = flip const + | otherwise = Pretty.color + + let + printTag Recommended = color Green "recommended" + printTag Latest = color Yellow "latest" + printTag Prerelease = color Red "prerelease" + printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') + printTag (UnknownTag t ) = t + printTag Old = "" + let rows = (\x -> if raw @@ -1552,13 +1567,13 @@ printListResult raw lr = do , intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag) , intercalate "," $ (if hlsPowered - then [color' Green "hls-powered"] + then [color Green "hls-powered"] else mempty ) - ++ (if fromSrc then [color' Blue "compiled"] else mempty) - ++ (if lStray then [color' Yellow "stray"] else mempty) + ++ (if fromSrc then [color Blue "compiled"] else mempty) + ++ (if lStray then [color Yellow "stray"] else mempty) ++ (if lNoBindist - then [color' Red "no-bindist"] + then [color Red "no-bindist"] else mempty ) ] @@ -1571,16 +1586,6 @@ printListResult raw lr = do forM_ padded $ \row -> putStrLn $ intercalate " " row where - printTag Recommended = color' Green "recommended" - printTag Latest = color' Yellow "latest" - printTag Prerelease = color' Red "prerelease" - printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') - printTag (UnknownTag t ) = t - printTag Old = "" - - color' = case raw of - True -> flip const - False -> color padTo str' x = let lstr = strWidth str'