backported changes from hbs2

flake.lock

@@ -36,15 +36,16 @@
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1736424074,
+        "lastModified": 1737544489,
-        "narHash": "sha256-c6X5VM9Rjz326Fjzfk0Wzv7qxCI7j1T873Ys5cl+FSQ=",
+        "narHash": "sha256-prTXYnEgUIIe5nMaE3rC9g6Ej3qtAKudd8T/QA+eyW8=",
-        "rev": "086d24061aa8ad7cf0ec189ccfd3f207cc73d366",
+        "ref": "refs/heads/master",
-        "revCount": 45,
+        "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"
       }

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";
 
 };
 

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

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

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 ::  Bind c m -> Bind c m
-hide = pure ()
+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
@@ -490,7 +503,9 @@ 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 "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)
+                     ) => Dict c m
-evalQQ = \case
+                       -> Syntax c -> RunM c m (Syntax c)
-  SymbolVal (Id w) | Text.isPrefixOf "," w -> do
+evalQQ d0 = \case
-    let what = Id (Text.drop 1 w)
+  -- SymbolVal (Id w) | Text.isPrefixOf "," w -> do
-    lookupValue what >>= eval
+  --   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)
 

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)

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