hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'origin/merge-requests/47'

This commit is contained in:
Julian Ospald 2020-12-20 01:45:49 +08:00
parent e8361c564a ead9d31647
commit eae58137c8
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
2 changed files with 64 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
app/ghcup/BrickMain.hs
View File

@ -44,6 +44,7 @@ import Data.Vector ( Vector
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Environment
import System.Exit import System.Exit
import System.IO.Unsafe import System.IO.Unsafe
import URI.ByteString import URI.ByteString
@ -118,8 +119,8 @@ showKey (Vty.KDown) = "↓"
showKey key = tail (show key) showKey key = tail (show key)
ui :: BrickState -> Widget String ui :: AttrMap -> BrickState -> Widget String
ui BrickState { appSettings = as@(BrickSettings {}), ..} ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
= ( padBottom Max = ( padBottom Max
$ ( withBorderStyle unicode $ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup") $ borderWithLabel (str "GHCup")
@ -150,9 +151,9 @@ ui BrickState { appSettings = as@(BrickSettings {}), ..}
ver = case lCross of ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer) Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim = if lNoBindist dim
then updateAttrMap (const dimAttributes) . withAttr "no-bindist" | lNoBindist = updateAttrMap (const dimAttrs) . withAttr "no-bindist"
else id | otherwise = id
hooray hooray
| elem Latest lTag && not lInstalled = | elem Latest lTag && not lInstalled =
withAttr "hooray" withAttr "hooray"
@ -239,39 +240,49 @@ minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App BrickState e String app :: AttrMap -> AttrMap -> App BrickState e String
app = App { appDraw = \st -> [ui st] app attrs dimAttrs =
, appHandleEvent = eventHandler App { appDraw = \st -> [ui dimAttrs st]
, appStartEvent = return , appHandleEvent = eventHandler
, appAttrMap = const defaultAttributes , appStartEvent = return
, appChooseCursor = neverShowCursor , appAttrMap = const attrs
} , appChooseCursor = neverShowCursor
}
defaultAttributes :: AttrMap defaultAttributes :: Bool -> AttrMap
defaultAttributes = attrMap defaultAttributes no_color = attrMap
Vty.defAttr Vty.defAttr
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue) [ ("active" , Vty.defAttr `withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red) , ("not-installed", Vty.defAttr `withForeColor` Vty.red)
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("set" , Vty.defAttr `withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("installed" , Vty.defAttr `withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("recommended" , Vty.defAttr `withForeColor` Vty.green)
, ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow) , ("latest" , Vty.defAttr `withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red) , ("prerelease" , Vty.defAttr `withForeColor` Vty.red)
, ("compiled" , Vty.defAttr `Vty.withForeColor` Vty.blue) , ("compiled" , Vty.defAttr `withForeColor` Vty.blue)
, ("stray" , Vty.defAttr `Vty.withForeColor` Vty.blue) , ("stray" , Vty.defAttr `withForeColor` Vty.blue)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic) , ("help" , Vty.defAttr `withStyle` Vty.italic)
, ("hooray" , Vty.defAttr `Vty.withForeColor` Vty.brightWhite) , ("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 withStyle = Vty.withStyle
dimAttributes = attrMap
dimAttributes :: Bool -> AttrMap
dimAttributes no_color = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim) (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) , ("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 :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st@(BrickState {..}) ev = do eventHandler st@(BrickState {..}) ev = do
@ -520,11 +531,13 @@ brickMain s l av pfreq' = do
writeIORef logger' l writeIORef logger' l
let runLogger = myLoggerT l let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just av) pfreq' eAppData <- getAppData (Just av) pfreq'
case eAppData of case eAppData of
Right ad -> Right ad ->
defaultMain defaultMain
app (app (defaultAttributes no_color) (dimAttributes no_color))
(BrickState ad (BrickState ad
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)

35
app/ghcup/Main.hs
View File

@ -59,7 +59,8 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import Safe import Safe
import System.Console.Pretty import System.Console.Pretty hiding ( color )
import qualified System.Console.Pretty as Pretty
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.IO hiding ( appendFile ) import System.IO hiding ( appendFile )
@ -1531,6 +1532,20 @@ printListResult raw lr = do
-- https://gitlab.haskell.org/ghc/ghc/issues/8118 -- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8 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 let
rows = rows =
(\x -> if raw (\x -> if raw
@ -1552,13 +1567,13 @@ printListResult raw lr = do
, intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag) , intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
, intercalate "," , intercalate ","
$ (if hlsPowered $ (if hlsPowered
then [color' Green "hls-powered"] then [color Green "hls-powered"]
else mempty else mempty
) )
++ (if fromSrc then [color' Blue "compiled"] else mempty) ++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color' Yellow "stray"] else mempty) ++ (if lStray then [color Yellow "stray"] else mempty)
++ (if lNoBindist ++ (if lNoBindist
then [color' Red "no-bindist"] then [color Red "no-bindist"]
else mempty else mempty
) )
] ]
@ -1571,16 +1586,6 @@ printListResult raw lr = do
forM_ padded $ \row -> putStrLn $ intercalate " " row forM_ padded $ \row -> putStrLn $ intercalate " " row
where 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 = padTo str' x =
let lstr = strWidth str' let lstr = strWidth str'