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 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)

35
app/ghcup/Main.hs
View File

@ -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'