From e2215bd0229772a807e0559501ae1ce6071848ad Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 22 Jan 2025 14:18:54 +0300 Subject: [PATCH] backported changes from hbs2 --- flake.lock | 11 +++-- flake.nix | 2 +- lib/Data/Config/Suckless/Almost/RPC.hs | 47 ++++++++++++++++++ lib/Data/Config/Suckless/Script.hs | 28 ++++++++++- lib/Data/Config/Suckless/Script/Internal.hs | 53 ++++++++++++++------- lib/Data/Config/Suckless/Syntax.hs | 14 ++++-- suckless-conf.cabal | 2 + 7 files changed, 129 insertions(+), 28 deletions(-) create mode 100644 lib/Data/Config/Suckless/Almost/RPC.hs diff --git a/flake.lock b/flake.lock index 1269031..8c69703 100644 --- a/flake.lock +++ b/flake.lock @@ -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" } diff --git a/flake.nix b/flake.nix index 725450e..74f518b 100644 --- a/flake.nix +++ b/flake.nix @@ -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"; }; diff --git a/lib/Data/Config/Suckless/Almost/RPC.hs b/lib/Data/Config/Suckless/Almost/RPC.hs new file mode 100644 index 0000000..6725bb2 --- /dev/null +++ b/lib/Data/Config/Suckless/Almost/RPC.hs @@ -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 + + diff --git a/lib/Data/Config/Suckless/Script.hs b/lib/Data/Config/Suckless/Script.hs index cbf1d51..cf507d0 100644 --- a/lib/Data/Config/Suckless/Script.hs +++ b/lib/Data/Config/Suckless/Script.hs @@ -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' + + diff --git a/lib/Data/Config/Suckless/Script/Internal.hs b/lib/Data/Config/Suckless/Script/Internal.hs index f031a72..c670a55 100644 --- a/lib/Data/Config/Suckless/Script/Internal.hs +++ b/lib/Data/Config/Suckless/Script/Internal.hs @@ -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) diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs index 9067aef..75fa4a2 100644 --- a/lib/Data/Config/Suckless/Syntax.hs +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -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) diff --git a/suckless-conf.cabal b/suckless-conf.cabal index 8011ace..b6f89ef 100644 --- a/suckless-conf.cabal +++ b/suckless-conf.cabal @@ -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