From acd6698dbfef4724740fcfd61c3e92361b8bb34d Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Wed, 12 Feb 2025 17:32:09 +0300
Subject: [PATCH] bf6 executable + maybe splices support

---
 Makefile                                      |  1 +
 .../fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs   | 12 ++++-
 miscellaneous/suckless-conf/bf6/Main.hs       | 52 +++++++++++++++++++
 .../Data/Config/Suckless/Script/Internal.hs   | 21 +++++++-
 .../suckless-conf/suckless-conf.cabal         | 14 +++++
 5 files changed, 96 insertions(+), 4 deletions(-)
 create mode 100644 miscellaneous/suckless-conf/bf6/Main.hs

diff --git a/Makefile b/Makefile
index 34625c22..ba85d90b 100644
--- a/Makefile
+++ b/Makefile
@@ -15,6 +15,7 @@ OUT_FILES := $(RT_FILES:.rt=.out)
 GHC_VERSION := 9.6.6
 BIN_DIR := ./bin
 BINS := \
+	bf6                \
   hbs2               \
   hbs2-peer          \
   hbs2-keyman        \
diff --git a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs
index 9c6050a9..70503875 100644
--- a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs
+++ b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs
@@ -181,7 +181,7 @@ instance MonadError SExpParseError m => MonadError SExpParseError (SExpM m) wher
 tokenizeSexp :: Text -> [TTok]
 tokenizeSexp txt =  do
   let spec = delims " \r\t" <> comment ";"
-                            <> punct ",`'{}()[]\n"
+                            <> punct "@,`'{}()[]\n"
                             <> sqq
                             <> uw
                             <> esc
@@ -230,7 +230,8 @@ parseTop txt = do
       [List one] -> lift $ S.yield (List one)
       xs    -> lift $ S.yield (List xs)
 
-sexp :: (ForMicroSexp c, MonadError SExpParseError m) => [TTok] -> SExpM m (MicroSexp c, [TTok])
+
+sexp :: forall c m . (ForMicroSexp c, MonadError SExpParseError m) => [TTok] -> SExpM m (MicroSexp c, [TTok])
 sexp s = case s of
   [] -> do
     checkBraces
@@ -248,10 +249,17 @@ sexp s = case s of
     (w, t) <- sexp rest
     pure (List [Symbol "`", w], t)
 
+  (TPunct ',' : TPunct '@' : rest) -> do
+    (w, t) <- sexp rest
+    pure $ (List [Symbol ",@", w], t)
+
   (TPunct ',' : rest) -> do
     (w, t) <- sexp rest
     pure (List [Symbol ",", w], t)
 
+  (TPunct '@' : TText x : rest) -> do
+    sexp (TText ("@" <> x) : rest)
+
   (TPunct '\n' : rest) -> succLno >> sexp rest
 
   (TPunct c : rest) | isSpace c  -> sexp rest
diff --git a/miscellaneous/suckless-conf/bf6/Main.hs b/miscellaneous/suckless-conf/bf6/Main.hs
new file mode 100644
index 00000000..352d6f5a
--- /dev/null
+++ b/miscellaneous/suckless-conf/bf6/Main.hs
@@ -0,0 +1,52 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module Main where
+
+import Data.Config.Suckless.Script
+import Data.Config.Suckless.Script.File as SF
+
+import System.Environment
+import System.IO qualified as IO
+import UnliftIO
+
+
+main :: IO ()
+main = do
+
+  cli <- getArgs <&> unlines . fmap unwords . splitForms
+           >>= either (error.show) pure . parseTop
+
+  let dict = makeDict do
+
+        internalEntries
+        SF.entries
+
+        entry $ bindMatch "--help" $ nil_ \case
+          HelpEntryBound what -> helpEntry what
+          [StringLike s]      -> helpList False (Just s)
+          _                   -> helpList False Nothing
+
+        entry $ bindMatch "debug:cli:show" $ nil_ \case
+          _ -> display cli
+
+
+  case cli of
+    [ListVal [SymbolVal "stdin"]] -> do
+      what <- liftIO getContents
+                >>= either (error.show) pure . parseTop
+
+      run dict what >>= eatNil display
+
+    [] -> do
+      eof <- liftIO IO.isEOF
+      if eof then
+        void $ run dict [mkForm  "help" []]
+      else do
+        what <- liftIO getContents
+                  >>= either (error.show) pure . parseTop
+
+        run dict what >>= eatNil display
+
+    _ -> do
+      run dict cli >>= eatNil display
+
diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs
index 1bed704e..90051825 100644
--- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs
+++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs
@@ -610,6 +610,20 @@ evalQQ d0 = \case
 
   other       -> pure other
 
+unsplice :: forall c m . ( IsContext c
+                         , MonadUnliftIO m
+                         , Exception (BadFormException c)
+                         ) => [Syntax c] -> RunM c m [Syntax c]
+unsplice s = u s
+  where
+    u ( ListVal [SymbolVal ",@", e] : es) = unnest <$> eval @c e  <*> u es
+    u ( e : es ) = (e:) <$> u es
+    u [] = pure []
+
+    unnest = \case
+      ListVal es -> mappend es
+      e -> (e :)
+
 eval :: forall c m . ( IsContext c
                      , MonadUnliftIO m
                      , Exception (BadFormException c)
@@ -659,11 +673,14 @@ eval' dict0 syn' = handle (handleForm syn') $ do
       ListVal [ SymbolVal ",", x] -> do
         pure  x
 
+      ListVal [ SymbolVal ",@", x] -> do
+        eval x
+
       ListVal [ SymbolVal "`", ListVal b] -> do
-        mkList <$> mapM (evalQQ dict) b
+        mkList <$> (unsplice b >>= mapM (evalQQ dict))
 
       ListVal [ SymbolVal "quasiquot", ListVal b] -> do
-        mkList <$> mapM (evalQQ dict) b
+        mkList <$> (mapM (evalQQ dict) =<< unsplice b)
 
       ListVal [ SymbolVal "quot", b] -> do
         pure b
diff --git a/miscellaneous/suckless-conf/suckless-conf.cabal b/miscellaneous/suckless-conf/suckless-conf.cabal
index 9bf6c115..8bce4b98 100644
--- a/miscellaneous/suckless-conf/suckless-conf.cabal
+++ b/miscellaneous/suckless-conf/suckless-conf.cabal
@@ -111,6 +111,20 @@ library
     hs-source-dirs:   lib
     default-language: Haskell2010
 
+
+
+executable bf6
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+          base, unliftio, suckless-conf
+
+    hs-source-dirs:   bf6
+    default-language: GHC2021
+
+
 test-suite spec
   import:          shared-properties
   type: exitcode-stdio-1.0