voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, suckless-config fix

This commit is contained in:
voidlizard 2024-10-17 14:36:21 +03:00
parent 79139245a2
commit c7fc9a1c1e
1 changed files with 34 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs
View File

@ -848,48 +848,57 @@ internalEntries = do
ss -> display (mkList ss) ss -> display (mkList ss)
let colorz = HM.fromList let colorz = HM.fromList
[ ("red", (Red, True)) [ ("red", pure (Red, True))
, ("red~", (Red, False)) , ("red~", pure (Red, False))
, ("green", (Green, True)) , ("green", pure (Green, True))
, ("green~", (Green, False)) , ("green~", pure (Green, False))
, ("yellow", (Yellow, True)) , ("yellow", pure (Yellow, True))
, ("yellow~", (Yellow, False)) , ("yellow~", pure (Yellow, False))
, ("blue", (Blue, True)) , ("blue", pure (Blue, True))
, ("blue~", (Blue, False)) , ("blue~", pure (Blue, False))
, ("magenta", (Magenta, True)) , ("magenta", pure (Magenta, True))
, ("magenta~",(Magenta, False)) , ("magenta~",pure (Magenta, False))
, ("cyan", (Cyan, True)) , ("cyan", pure (Cyan, True))
, ("cyan~", (Cyan, False)) , ("cyan~", pure (Cyan, False))
, ("white", (White, True)) , ("white", pure (White, True))
, ("white~", (White, False)) , ("white~", pure (White, False))
, ("black", (Black, True)) , ("black", pure (Black, True))
, ("black~", (Black, False)) , ("black~", pure (Black, False))
, ("_", mzero)
] ]
let fgc fg = case HM.lookup fg colorz of let fgc fg = case join (HM.lookup fg colorz) of
Just (co, True) -> color co Just (co, True) -> color co
Just (co, False) -> colorDull co Just (co, False) -> colorDull co
Nothing -> mempty Nothing -> mempty
let niceTerm f = \case
LitStrVal x -> do
let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty x)
mkStr s
other -> do
let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty other)
mkStr s
entry $ bindMatch "ansi" $ \case entry $ bindMatch "ansi" $ \case
[ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do [ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do
let b = case HM.lookup bg colorz of let b = case join (HM.lookup bg colorz) of
Just (co, True) -> bgColor co Just (co, True) -> bgColor co
Just (co, False) -> bgColorDull co Just (co, False) -> bgColorDull co
Nothing -> mempty Nothing -> mempty
let f = b <> fgc fg let f = b <> fgc fg
let wtf = show $ pretty term pure $ niceTerm f term
let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf)
pure $ mkStr x
[ SymbolVal fg, s] | HM.member fg colorz -> do [ SymbolVal fg, s] | HM.member fg colorz -> do
let f = fgc fg let f = fgc fg
let wtf = show $ pretty s pure $ niceTerm f s
let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf) -- let wtf = show $ pretty s
-- error $ show x -- let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf)
pure $ mkStr x -- -- error $ show x
-- pure $ mkStr x
_ -> throwIO (BadFormException @c nil) _ -> throwIO (BadFormException @c nil)