voidlizard
/
suckless-conf
mirror of https://github.com/voidlizard/suckless-conf.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

backported changes from hbs2

This commit is contained in:
voidlizard 2025-01-22 14:18:54 +03:00
parent 09c70e6694
commit e2215bd022
7 changed files with 129 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
flake.lock
View File

@ -36,15 +36,16 @@
"nixpkgs": "nixpkgs"
},
"locked": {
"lastModified": 1736424074,
"narHash": "sha256-c6X5VM9Rjz326Fjzfk0Wzv7qxCI7j1T873Ys5cl+FSQ=",
"rev": "086d24061aa8ad7cf0ec189ccfd3f207cc73d366",
"revCount": 45,
"lastModified": 1737544489,
"narHash": "sha256-prTXYnEgUIIe5nMaE3rC9g6Ej3qtAKudd8T/QA+eyW8=",
"ref": "refs/heads/master",
"rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
"revCount": 46,
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
},
"original": {
"rev": "086d24061aa8ad7cf0ec189ccfd3f207cc73d366",
"rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
}

2
flake.nix
View File

@ -7,7 +7,7 @@ inputs = {
fuzzy.url =
# "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=bd3a38904864d5cc333974e7b029412607b46871";
"git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?rev=086d24061aa8ad7cf0ec189ccfd3f207cc73d366";
"git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?rev=9e41a735a8bdb02b2b5c405341d8b3b98242f021";
};

47
lib/Data/Config/Suckless/Almost/RPC.hs Normal file
View File

@ -0,0 +1,47 @@
{-# Language TypeOperators #-}
module Data.Config.Suckless.Almost.RPC where
import Data.Config.Suckless
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString.Lazy as LBS
import Data.ByteString.Lazy.Char8 as LBS8
import Data.Function
import Data.Text.Encoding.Error qualified as TE
import Data.Text.Encoding qualified as TE
import Data.Text qualified as T
import Data.Typeable
import Prettyprinter
import System.Process.Typed
data CallProcException =
CallProcException ExitCode
deriving (Show,Typeable)
instance Exception CallProcException
-- FIXME: to-suckless-script
callProc :: forall m . (MonadIO m)
=> FilePath
-> [String]
-> [Syntax C]
-> m [Syntax C]
callProc name params syn = do
let input = fmap (LBS.fromStrict . TE.encodeUtf8 . T.pack . show . pretty) syn
& LBS8.unlines
& byteStringInput
let what = proc name params & setStderr closed & setStdin input
(code, i, _) <- readProcess what
unless (code == ExitSuccess) do
liftIO $ throwIO (CallProcException code)
let s = TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i)
parseTop s & either (liftIO . throwIO) pure

28
lib/Data/Config/Suckless/Script.hs
View File

@ -1,5 +1,6 @@
{-# Language UndecidableInstances #-}
{-# Language PatternSynonyms #-}
{-# Language RecordWildCards #-}
module Data.Config.Suckless.Script
( module Exported
, module Data.Config.Suckless.Script
@ -15,6 +16,7 @@ import Prettyprinter
import Prettyprinter.Render.Terminal
import Data.List qualified as List
import Data.Text qualified as Text
import Data.String
import UnliftIO
@ -28,13 +30,13 @@ helpList hasDoc p = do
d <- ask >>= readTVarIO
let ks = [k | Id k <- List.sort (HM.keys d)
, match k
, not hasDoc || docDefined (HM.lookup (Id k) d)
, docDefined (HM.lookup (Id k) d) || not hasDoc
]
display_ $ vcat (fmap pretty ks)
where
docDefined (Just (Bind (Just w) _)) = True
docDefined (Just (Bind (Just Man{..}) _)) | not manHidden = True
docDefined _ = False
helpEntry :: MonadUnliftIO m => Id -> RunM c m ()
@ -48,3 +50,25 @@ helpEntry what = do
pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
splitOpts :: [(Id,Int)]
-> [Syntax C]
-> ([Syntax C], [Syntax C])
splitOpts def opts' = flip fix (mempty, opts) $ \go -> \case
(acc, []) -> acc
( (o,a), r@(StringLike x) : rs ) -> do
case HM.lookup (fromString x) omap of
Nothing -> go ((o, a <> [r]), rs)
Just n -> do
let (w, rest) = List.splitAt n rs
let result = mkList @C ( r : w )
go ( (o <> [result], a), rest )
( (o,a), r : rs ) -> do
go ((o, a <> [r]), rs)
where
omap = HM.fromList [ (p, x) | (p,x) <- def ]
opts = opts'

53
lib/Data/Config/Suckless/Script/Internal.hs
View File

@ -23,6 +23,8 @@ import Data.Data
import Data.Function as Export
import Data.Functor as Export
import Data.Hashable
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Kind
@ -393,8 +395,20 @@ makeDict w = execWriter ( fromMakeDict w )
entry :: Dict c m -> MakeDictM c m ()
entry = tell
hide :: MakeDictM c m ()
hide = pure ()
hide :: Bind c m -> Bind c m
hide (Bind w x) = Bind (Just updatedMan) x
where
updatedMan = case w of
Nothing -> mempty { manHidden = True }
Just man -> man { manHidden = True }
hidden :: MakeDictM c m () -> MakeDictM c m ()
hidden = censor (HM.map hide)
hidePrefix :: Id -> MakeDictM c m () -> MakeDictM c m ()
hidePrefix (Id p) = censor (HM.filterWithKey exclude)
where
exclude (Id k) _ = not (Text.isPrefixOf p k)
desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
desc txt = censor (HM.map setDesc)
@ -414,7 +428,6 @@ returns tp txt = censor (HM.map setReturns)
w0 = mempty { manReturns = Just (ManReturns tp txt) }
setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
where
@ -489,8 +502,10 @@ apply_ :: forall c m . ( IsContext c
apply_ s args = case s of
ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args
SymbolVal "quot" -> pure $ mkList args
SymbolVal "quasiquot" -> mkList <$> mapM evalQQ args
SymbolVal "quot" -> pure $ mkList args
SymbolVal "quote" -> pure $ mkList args
SymbolVal "quasiquot" -> mkList <$> mapM (evalQQ mempty) args
SymbolVal "quasiquote" -> mkList <$> mapM (evalQQ mempty) args
SymbolVal what -> apply what args
Lambda d body -> applyLambda d body args
e -> throwIO $ NotLambda e
@ -507,7 +522,7 @@ apply "quot" args = do
pure $ mkList args
apply "quasiquot" args = do
mkList <$> mapM evalQQ args
mkList <$> mapM (evalQQ mempty) args
apply name args' = do
-- notice $ red "APPLY" <+> pretty name
@ -563,13 +578,16 @@ bindBuiltins dict = do
evalQQ :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => Syntax c -> RunM c m (Syntax c)
evalQQ = \case
SymbolVal (Id w) | Text.isPrefixOf "," w -> do
let what = Id (Text.drop 1 w)
lookupValue what >>= eval
) => Dict c m
-> Syntax c -> RunM c m (Syntax c)
evalQQ d0 = \case
-- SymbolVal (Id w) | Text.isPrefixOf "," w -> do
-- let what = Id (Text.drop 1 w)
-- lookupValue what >>= eval
List c es -> List c <$> mapM evalQQ es
ListVal [ SymbolVal ",", w ] -> eval' d0 w
List c es -> List c <$> mapM (evalQQ d0) es
other -> pure other
@ -595,8 +613,6 @@ eval' dict0 syn = handle (handleForm syn) $ do
-- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
-- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
case syn of
SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
@ -617,11 +633,14 @@ eval' dict0 syn = handle (handleForm syn) $ do
ListVal [ SymbolVal "'", x] -> do
pure x
ListVal [ SymbolVal ",", x] -> do
pure x
ListVal [ SymbolVal "`", ListVal b] -> do
mkList <$> mapM evalQQ b
mkList <$> mapM (evalQQ dict) b
ListVal [ SymbolVal "quasiquot", ListVal b] -> do
mkList <$> mapM evalQQ b
mkList <$> mapM (evalQQ dict) b
ListVal [ SymbolVal "quot", ListVal b] -> do
pure $ mkList b
@ -921,7 +940,7 @@ internalEntries = do
throwIO (BadFormException @C nil)
entry $ bindMatch "quasiquot" $ \case
[ syn ] -> mkList . List.singleton <$> evalQQ syn
[ syn ] -> mkList . List.singleton <$> (evalQQ mempty) syn
_ -> do
throwIO (BadFormException @C nil)

14
lib/Data/Config/Suckless/Syntax.hs
View File

@ -29,6 +29,7 @@ module Data.Config.Suckless.Syntax
, pattern LitBoolVal
, pattern LitScientificVal
, pattern StringLike
, pattern TextLike
, pattern StringLikeList
, pattern Nil
, pattern OpaqueVal
@ -82,22 +83,29 @@ pattern LitBoolVal v <- Literal _ (LitBool v)
pattern ListVal :: [Syntax c] -> Syntax c
pattern ListVal v <- List _ v
stringLike :: Syntax c -> Maybe String
stringLike = \case
LitStrVal s -> Just $ Text.unpack s
SymbolVal (Id s) -> Just $ Text.unpack s
_ -> Nothing
textLike :: Syntax c -> Maybe Text
textLike = \case
LitStrVal s -> Just s
SymbolVal (Id s) -> Just s
x -> Nothing
stringLikeList :: [Syntax c] -> [String]
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString
pattern StringLike :: forall {c} . String -> Syntax c
pattern StringLike e <- (stringLike -> Just e)
pattern TextLike :: forall {c} . Text -> Syntax c
pattern TextLike e <- (textLike -> Just e)
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
pattern StringLikeList e <- (stringLikeList -> e)
@ -139,7 +147,7 @@ class IsLiteral a where
newtype Id =
Id Text
deriving newtype (IsString,Pretty)
deriving newtype (IsString,Pretty,Semigroup,Monoid)
deriving stock (Data,Generic,Show,Eq,Ord)
type ForOpaque a = (Typeable a, Eq a)

2
suckless-conf.cabal
View File

@ -67,6 +67,7 @@ library
, Data.Config.Suckless.KeyValue
, Data.Config.Suckless.Script
, Data.Config.Suckless.Script.File
, Data.Config.Suckless.Almost.RPC
other-modules:
Data.Config.Suckless.Types
@ -95,6 +96,7 @@ library
, text
, time
, transformers
, typed-process
, unliftio
, unordered-containers
, vector