backported changes from hbs2

Flake lock file updates:

• Updated input 'fuzzy':
    'git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?rev=831879978213a1aed15ac70aa116c33bcbe964b8&tag=0.1.3.1' (2024-05-17)
  → 'git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=refs/heads/master&rev=a834b152e29d632c816eefe117036e5d9330bd03' (2024-09-24)
• Updated input 'fuzzy/nixpkgs':
    'github:NixOS/nixpkgs/442d407992384ed9c0e6d352de75b69079904e4e' (2024-02-09)
  → 'github:NixOS/nixpkgs/568bfef547c14ca438c56a0bece08b8bb2b71a9c' (2024-09-23)
• Updated input 'haskell-flake-utils':
    'github:ivanovs-4/haskell-flake-utils/896219e5bde6efac72198550454e9dd9b5ed9ac9' (2022-12-30)
  → 'github:ivanovs-4/haskell-flake-utils/3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2' (2024-02-13)
• Updated input 'nixpkgs':
    'github:NixOS/nixpkgs/442d407992384ed9c0e6d352de75b69079904e4e' (2024-02-09)
  → 'github:NixOS/nixpkgs/568bfef547c14ca438c56a0bece08b8bb2b71a9c' (2024-09-23)

flake.lock

@@ -36,17 +36,18 @@
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1715918584,
-        "narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
-        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
-        "revCount": 63,
+        "lastModified": 1737544489,
+        "narHash": "sha256-prTXYnEgUIIe5nMaE3rC9g6Ej3qtAKudd8T/QA+eyW8=",
+        "ref": "refs/heads/master",
+        "rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
+        "revCount": 46,
         "type": "git",
-        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
       },
       "original": {
-        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
+        "rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
         "type": "git",
-        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
       }
     },
     "haskell-flake-utils": {
@@ -72,11 +73,11 @@
         "flake-utils": "flake-utils_2"
       },
       "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
         "owner": "ivanovs-4",
         "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
         "type": "github"
       },
       "original": {
@@ -87,33 +88,33 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1707451808,
-        "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
+        "lastModified": 1727089097,
+        "narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
+        "rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
         "type": "github"
       },
       "original": {
         "owner": "NixOS",
+        "ref": "nixpkgs-unstable",
         "repo": "nixpkgs",
-        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
         "type": "github"
       }
     },
     "nixpkgs_2": {
       "locked": {
-        "lastModified": 1707451808,
-        "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
+        "lastModified": 1727089097,
+        "narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
+        "rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
         "type": "github"
       },
       "original": {
         "owner": "NixOS",
+        "ref": "nixpkgs-unstable",
         "repo": "nixpkgs",
-        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
         "type": "github"
       }
     },

flake.nix

@@ -2,12 +2,12 @@
 description = "suckless-cong: sexp based configs";
 
 inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs?rev=442d407992384ed9c0e6d352de75b69079904e4e";
+    nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
     haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
 
     fuzzy.url =
       # "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=bd3a38904864d5cc333974e7b029412607b46871";
-      "git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1&rev=831879978213a1aed15ac70aa116c33bcbe964b8";
+      "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
@@ -8,12 +9,14 @@ module Data.Config.Suckless.Script
 import Data.Config.Suckless as Exported
 import Data.Config.Suckless.Script.Internal as Exported
 
+import Control.Monad
 import Control.Monad.Reader
 import Data.HashMap.Strict qualified as HM
 import Prettyprinter
 import Prettyprinter.Render.Terminal
 import Data.List qualified as List
 import Data.Text qualified as Text
+import Data.String
 import UnliftIO
 
 
@@ -27,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 ()
@@ -47,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/File.hs

@@ -15,6 +15,8 @@ import System.FilePath
 import System.FilePattern
 import Data.HashSet qualified as HS
 
+import Prettyprinter
+
 import Lens.Micro.Platform
 import UnliftIO
 import Control.Concurrent.STM qualified as STM
@@ -67,12 +69,12 @@ entries = do
   entry $ bindMatch "glob" $ \syn -> do
 
     (p,i,d) <- case syn of
-                 [] -> pure (["*"], [], ".")
+                 [] -> pure (["**/*"], ["**/.*"], ".")
 
-                 [StringLike d, StringLike i, StringLike e] -> do
-                    pure ([i], [e], d)
+                 s@[StringLike d, ListVal (StringLikeList i) ] -> do
+                    pure (i, [], d)
 
-                 [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
+                 s@[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e) ] -> do
                     pure (i, e, d)
 
                  _ -> throwIO (BadFormException @c nil)

lib/Data/Config/Suckless/Script/Internal.hs

@@ -2,6 +2,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language PatternSynonyms #-}
 {-# Language ViewPatterns #-}
+{-# Language RecordWildCards #-}
 module Data.Config.Suckless.Script.Internal
   ( module Data.Config.Suckless.Script.Internal
   , module Export
@@ -10,15 +11,20 @@ module Data.Config.Suckless.Script.Internal
 import Data.Config.Suckless
 
 import Control.Applicative
+import Control.Monad
 import Control.Monad.Identity
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
 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
@@ -29,6 +35,8 @@ import Data.String
 import Data.Text.IO qualified as TIO
 import Data.Text qualified as Text
 import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
 import Data.Time.Clock.POSIX
 import GHC.Generics hiding (C)
 import Prettyprinter
@@ -115,7 +123,7 @@ instance IsString ManDesc where
 instance Pretty (Man a) where
   pretty e =   "NAME"
              <> line
-             <> indent 8 (pretty (manName e) <> fmtBrief e)
+             <> indent 4 (pretty (manName e) <> fmtBrief e)
              <> line
              <> fmtSynopsis
              <> fmtDescription
@@ -130,14 +138,14 @@ instance Pretty (Man a) where
       Nothing -> mempty
       Just (ManReturns t s) ->
         line <> "RETURN VALUE" <> line
-        <> indent 8 (
+        <> indent 4 (
             if not (Text.null s) then
               (pretty t <> hsep ["","-",""] <> pretty s) <> line
             else pretty t )
 
     fmtDescription = line
       <> "DESCRIPTION" <> line
-      <> indent 8 ( case manDesc e of
+      <> indent 4 ( case manDesc e of
            Nothing -> pretty (manBrief e)
            Just x  -> pretty x)
       <> line
@@ -156,13 +164,13 @@ instance Pretty (Man a) where
       es -> line
         <> "EXAMPLES"
         <> line
-        <> indent 8 ( vcat (fmap pretty es) )
+        <> indent 4 ( vcat (fmap pretty es) )
 
     synEntry (ManSynopsis (ManApply [])) =
-      indent 8 ( parens (pretty (manName e)) ) <> line
+      indent 4 ( parens (pretty (manName e)) ) <> line
 
     synEntry (ManSynopsis (ManApply xs)) = do
-      indent 8 do
+      indent 4 do
         parens (pretty (manName e) <+>
          hsep [ pretty n | ManApplyArg t n <- xs ]  )
          <> line
@@ -263,6 +271,12 @@ eatNil f = \case
 class IsContext c => MkInt c s where
   mkInt :: s -> Syntax c
 
+class IsContext c => MkDouble c s where
+  mkDouble :: s -> Syntax c
+
+instance (IsContext c, RealFrac s) => MkDouble c s where
+  mkDouble v = Literal noContext $ LitScientific (realToFrac v)
+
 instance (Integral i, IsContext c) => MkInt c i where
   mkInt n = Literal noContext $ LitInt (fromIntegral n)
 
@@ -317,6 +331,7 @@ isPair = \case
 
 data BindAction c ( m :: Type -> Type)  =
     BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
+  | BindMacro  { fromMacro  :: [Syntax c] -> RunM c m (Syntax c) }
   | BindValue  (Syntax c)
 
 data Bind c ( m :: Type -> Type)  = Bind
@@ -331,18 +346,11 @@ newtype NameNotBoundException =
   deriving stock Show
   deriving newtype (Generic,Typeable)
 
-newtype NotLambda = NotLambda Id
-                    deriving stock Show
-                    deriving newtype (Generic,Typeable)
-
-instance Exception NotLambda
 
 data BadFormException c = BadFormException (Syntax c)
                         | ArityMismatch (Syntax c)
-
-newtype TypeCheckError c = TypeCheckError (Syntax c)
-
-instance Exception (TypeCheckError C)
+                        | NotLambda (Syntax c)
+                        | TypeCheckError (Syntax c)
 
 newtype BadValueException = BadValueException String
                             deriving stock Show
@@ -353,8 +361,7 @@ instance Exception NameNotBoundException
 instance IsContext c => Show (BadFormException c) where
   show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
   show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
-
-instance IsContext c => Show (TypeCheckError c) where
+  show (NotLambda sy) = show $ "NotLambda" <+> pretty sy
   show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
 
 instance Exception (BadFormException C)
@@ -388,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)
@@ -409,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
@@ -433,7 +451,7 @@ opt n d = n <+> "-" <+> d
 examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
 examples (ManExamples s) = censor (HM.map setExamples )
   where
-    ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
+    ex = ManExamples (Text.unlines $ Text.lines (Text.strip s))
     ex0 = mempty { manExamples = [ex] }
     setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
 
@@ -484,9 +502,13 @@ 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 "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 $ BadFormException @c s
+  e                  -> throwIO $ NotLambda e
 
 apply :: forall c m . ( IsContext c
                       , MonadUnliftIO m
@@ -495,6 +517,13 @@ apply :: forall c m . ( IsContext c
       => Id
       -> [Syntax c]
       -> RunM c m (Syntax c)
+
+apply "quot" args = do
+  pure $ mkList args
+
+apply "quasiquot" args = do
+  mkList <$> mapM (evalQQ mempty) args
+
 apply name args' = do
   -- notice $ red "APPLY" <+> pretty name
   what <- ask >>=  readTVarIO <&> HM.lookup name
@@ -505,8 +534,11 @@ apply name args' = do
     Just (BindValue (Lambda argz body) )  -> do
       applyLambda argz body args'
 
+    Just (BindMacro macro) -> do
+      macro args'
+
     Just (BindValue _) -> do
-      throwIO (NotLambda name)
+      throwIO (NotLambda (mkSym @c name))
 
     Nothing -> throwIO (NameNotBound name)
 
@@ -542,26 +574,99 @@ bindBuiltins  dict = do
   atomically do
     modifyTVar t (<> dict)
 
+
+evalQQ :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     ) => 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
+
+  ListVal [ SymbolVal ",", w ] -> eval' d0 w
+
+  List c es   -> List c <$> mapM (evalQQ d0) es
+
+  other       -> pure other
+
 eval :: forall c m . ( IsContext c
                      , MonadUnliftIO m
                      , Exception (BadFormException c)
-                     ) => Syntax c -> RunM c m (Syntax c)
-eval syn = handle (handleForm syn) $ do
+                     )
+                       => Syntax c
+                       -> RunM c m (Syntax c)
+eval = eval' mempty
 
-    dict <- ask >>= readTVarIO
+eval' :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     ) => Dict c m
+                       -> Syntax c
+                       -> RunM c m (Syntax c)
+eval' dict0 syn = handle (handleForm syn) $ do
+
+    dict1 <- ask >>= readTVarIO
+
+    let dict = dict0 <> dict1
+
+    -- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
 
     case syn of
 
+      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+        pure (mkSym @c (Text.drop 1 s))
+
       ListVal [ w, SymbolVal ".", b] -> do
         pure  $ mkList  [w, b]
 
+      ListVal [ SymbolVal ":", b] -> do
+        pure  $ mkList [b]
+
+      ListVal [ SymbolVal "'", ListVal b] -> do
+        pure  $ mkList b
+
+      ListVal [ SymbolVal "'", StringLike x] -> do
+        pure  $ mkSym x
+
+      ListVal [ SymbolVal "'", x] -> do
+        pure  x
+
+      ListVal [ SymbolVal ",", x] -> do
+        pure  x
+
+      ListVal [ SymbolVal "`", ListVal b] -> do
+        mkList <$> mapM (evalQQ dict) b
+
+      ListVal [ SymbolVal "quasiquot", ListVal b] -> do
+        mkList <$> mapM (evalQQ dict) b
+
       ListVal [ SymbolVal "quot", ListVal b] -> do
         pure  $ mkList  b
 
+      ListVal [ SymbolVal "eval", e ] -> eval e >>= eval
+
       ListVal [SymbolVal "define", SymbolVal what, e] -> do
         ev <- eval e
         bind what ev>> pure nil
 
+      ListVal [SymbolVal "define-macro",  LambdaArgs (name:argz), e] -> do
+        t <- ask
+
+        let runMacro argvalz = do
+             de <- forM (zip argz argvalz) $ \(n,e) -> do
+                     v <- eval e
+                     pure (n, Bind mzero (BindValue v))
+
+             let d0 = HM.fromList de
+
+             eval' d0 e >>= eval' d0
+
+        let b = Bind mzero (BindMacro runMacro)
+        atomically $ modifyTVar t (HM.insert name b)
+        pure nil
+
       ListVal [SymbolVal "lambda", arglist, body] -> do
         pure $ mkForm @c "lambda" [ arglist, body ]
 
@@ -590,23 +695,29 @@ eval syn = handle (handleForm syn) $ do
       ListVal (SymbolVal name : args') -> do
         apply name args'
 
-      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
-        pure (mkSym @c (Text.drop 1 s))
+      ListVal (e' : args') -> do
+        -- e <- eval e'
+        apply_ e' args'
 
       SymbolVal name | HM.member name dict -> do
-        let what = HM.lookup name dict
+
+
+        let what = HM.lookup name dict0 <|> HM.lookup name dict1
                      & maybe (BindValue (mkSym name)) bindAction
 
+        -- liftIO $ print $ "LOOKUP" <+> pretty name <+> pretty what
+
         case what of
           BindValue e  -> pure e
           BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
+          BindMacro _  -> pure nil
 
       e@(SymbolVal name) | not (HM.member name dict) -> do
         pure e
 
       e@Literal{} -> pure e
 
-      e -> throwIO $ BadFormException @c e
+      e -> throwIO $ NotLambda @c e
 
   where
     handleForm syn = \case
@@ -614,6 +725,9 @@ eval syn = handle (handleForm syn) $ do
         throwIO (BadFormException syn)
       (ArityMismatch s  :: BadFormException c) -> do
         throwIO (ArityMismatch syn)
+      (TypeCheckError s  :: BadFormException c) -> do
+        throwIO (TypeCheckError syn)
+      other -> throwIO other
 
 runM :: forall c m a. ( IsContext c
                       , MonadUnliftIO m
@@ -631,6 +745,13 @@ run d sy = do
   tvd <- newTVarIO d
   lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
 
+runEval :: forall c m . ( IsContext c
+                    , MonadUnliftIO m
+                    , Exception (BadFormException c)
+                    ) => TVar (Dict c m) -> [Syntax c] -> m (Syntax c)
+runEval tvd sy = do
+  lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
+
 evalTop :: forall c m . ( IsContext c
                         , MonadUnliftIO m
                         , Exception (BadFormException c))
@@ -643,23 +764,37 @@ bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
   where
     man = Just $ mempty { manName = Just (manNameOf n) }
 
+bindMacro :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
+bindMacro n fn = HM.singleton n (Bind man (BindMacro fn))
+  where
+    man = Just $ mempty { manName = Just (manNameOf n) }
+
 bindValue :: Id -> Syntax c -> Dict c m
 bindValue n e = HM.singleton n (Bind mzero (BindValue e))
 
+lookupValue :: forall c m . (IsContext c, MonadUnliftIO m)
+            => Id -> RunM c m (Syntax c)
+lookupValue i = do
+  ask  >>= readTVarIO
+       <&> (fmap bindAction . HM.lookup i)
+       >>= \case
+          Just (BindValue s) -> pure s
+          _  -> throwIO (NameNotBound i)
+
 nil :: forall c . IsContext c => Syntax c
 nil = List noContext []
 
 nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
 nil_ m w = m w >> pure (List noContext [])
 
-fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
+fixContext :: forall c1 c2 . (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
 fixContext = go
   where
     go = \case
       List    _ xs -> List noContext (fmap go xs)
       Symbol  _ w  -> Symbol noContext w
       Literal _ l  -> Literal noContext l
-
+      OpaqueValue box  -> OpaqueValue box
 
 fmt :: Syntax c -> Doc ann
 fmt = \case
@@ -769,6 +904,23 @@ internalEntries = do
       z ->
         throwIO (BadFormException @C nil)
 
+
+    entry $ bindMatch "eval" $ \syn -> do
+      r <- mapM eval syn
+      pure $ lastDef nil r
+
+    entry $ bindMatch "id" $ \case
+      [ e ] -> pure e
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "inc" $ \case
+      [ LitIntVal n ] -> pure (mkInt (succ n))
+      _ -> throwIO (TypeCheckError @C  nil)
+
+    entry $ bindMatch "dec" $ \case
+      [ LitIntVal n ] -> pure (mkInt (succ n))
+      _ -> throwIO (TypeCheckError @C  nil)
+
     entry $ bindMatch "map" $ \syn -> do
       case syn of
         [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
@@ -782,6 +934,16 @@ internalEntries = do
         _ -> do
           throwIO (BadFormException @C nil)
 
+    entry $ bindMatch "quot" $ \case
+      [ syn ] -> pure $ mkList [syn]
+      _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "quasiquot" $ \case
+      [ syn ] -> mkList . List.singleton <$> (evalQQ mempty) syn
+      _ -> do
+          throwIO (BadFormException @C nil)
+
     entry $ bindMatch "head" $ \case
       [ ListVal es ] -> pure (head es)
       _ -> throwIO (TypeCheckError @C nil)
@@ -821,6 +983,61 @@ internalEntries = do
       [ sy ] -> display sy
       ss     -> display (mkList ss)
 
+    let colorz = HM.fromList
+          [ ("red",     pure (Red, True))
+          , ("red~",    pure (Red, False))
+          , ("green",   pure (Green, True))
+          , ("green~",  pure (Green, False))
+          , ("yellow",  pure (Yellow, True))
+          , ("yellow~", pure (Yellow, False))
+          , ("blue",    pure (Blue, True))
+          , ("blue~",   pure (Blue, False))
+          , ("magenta", pure (Magenta, True))
+          , ("magenta~",pure (Magenta, False))
+          , ("cyan",    pure (Cyan, True))
+          , ("cyan~",   pure (Cyan, False))
+          , ("white",   pure (White, True))
+          , ("white~",  pure (White, False))
+          , ("black",   pure (Black, True))
+          , ("black~",  pure (Black, False))
+          , ("_",       mzero)
+          ]
+
+
+    let fgc fg = case join (HM.lookup fg colorz) of
+          Just (co, True)  -> color co
+          Just (co, False) -> colorDull co
+          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
+      [ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do
+        let b = case join (HM.lookup bg colorz) of
+                  Just (co, True)  -> bgColor co
+                  Just (co, False) -> bgColorDull co
+                  Nothing -> mempty
+
+        let f = b <> fgc fg
+        pure $ niceTerm f term
+
+      [ SymbolVal fg, s] | HM.member fg colorz -> do
+        let f = fgc fg
+        pure $ niceTerm f s
+        -- let wtf = show $ pretty s
+        -- let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf)
+        -- -- error $ show x
+        -- pure $ mkStr x
+
+      _  -> throwIO (BadFormException @c nil)
+
     brief "prints new line character to stdout"
       $ entry $ bindMatch "newline" $ nil_ $ \case
           [] -> liftIO (putStrLn "")
@@ -835,7 +1052,7 @@ internalEntries = do
       [ sy ] -> display sy >> liftIO (putStrLn "")
       ss     -> mapM_ display ss >> liftIO (putStrLn "")
 
-    entry $ bindMatch "str:read-stdin" $ \case
+    entry $ bindMatch "str:stdin" $ \case
       [] -> liftIO getContents <&> mkStr @c
 
       _ -> throwIO (BadFormException @c nil)
@@ -845,7 +1062,7 @@ internalEntries = do
       _ -> throwIO (BadFormException @c nil)
 
     brief "reads file as a string" do
-      entry $ bindMatch "str:read-file" $ \case
+      entry $ bindMatch "str:file" $ \case
         [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
 
         _ -> throwIO (BadFormException @c nil)
@@ -858,13 +1075,39 @@ internalEntries = do
 
     entry $ bindValue "space" $ mkStr " "
 
-    entry $ bindMatch "parse-top" $ \case
+    let doParseTop w l s =
+         parseTop s & either (const nil) (mkForm w . fmap ( l . fixContext) )
+
+    let wrapWith e = \case
+          List c es -> List c (e : es)
+          other     -> other
+    let lwrap = \case
+          e@(SymbolVal x) -> wrapWith e
+          _ -> id
+
+    brief "parses string as toplevel and produces a form"
+     $ desc "parse:top:string SYMBOL STRING-LIKE"
+     $ entry $ bindMatch "parse:top:string" $ \case
 
         [SymbolVal w, LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
+          pure $  doParseTop w id s
 
-      [LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
+        [SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do
+          pure $  doParseTop w (lwrap e) s
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "parses file as toplevel form and produces a form"
+     $ desc "parse:top:file SYMBOL <FILENAME>"
+     $ entry $ bindMatch "parse:top:file" $ \case
+
+        [SymbolVal w, StringLike fn] -> do
+          s <- liftIO $ TIO.readFile fn
+          pure $  doParseTop w id s
+
+        [SymbolVal w, e@(SymbolVal r), StringLike fn] -> do
+          s <- liftIO $ TIO.readFile fn
+          pure $  doParseTop w (lwrap e)  s
 
         _ -> throwIO (BadFormException @c nil)
 
@@ -966,3 +1209,60 @@ internalEntries = do
       _ -> throwIO (BadFormException @c nil)
 
 
+    brief "decodes bytes as utf8 text"
+     $ desc "bytes:decode <BYTES>"
+     $ entry $ bindMatch "bytes:decode" $ \case
+        [ OpaqueVal box ] -> do
+
+          let lbs' = fromOpaque @LBS.ByteString box
+                      <|>
+                     (LBS.fromStrict <$> fromOpaque @BS.ByteString box)
+
+          lbs <- maybe (throwIO (UnexpectedType "unknown / ByteString")) pure lbs'
+
+          -- TODO: maybe-throw-on-invalid-encoding
+          let txt = decodeUtf8With ignore (LBS.toStrict lbs)
+
+          pure $ mkStr txt
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+    brief "reads bytes from a file"
+     $ desc "bytes:file FILE"
+     $ entry $ bindMatch "bytes:file" $ \case
+        [ StringLike fn ] -> do
+          liftIO (LBS.readFile fn) >>= mkOpaque
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "reads bytes from a STDIN"
+     $ desc "bytes:stdin"
+     $ entry $ bindMatch "bytes:stdin" $ \case
+        [] -> do
+          liftIO LBS.getContents >>= mkOpaque
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "writes bytes to STDOUT"
+     $ desc "bytes:put <BYTES>"
+     $ entry $ bindMatch "bytes:put" $ nil_ $ \case
+        [isOpaqueOf @LBS.ByteString -> Just s ] -> do
+          liftIO $ LBS.putStr s
+
+        [isOpaqueOf @ByteString -> Just s ] -> do
+          liftIO $ BS.putStr s
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "writes bytes to FILE"
+     $ desc "bytes:write <FILE> <BYTES>"
+     $ entry $ bindMatch "bytes:write" $ nil_ $ \case
+        [StringLike fn, isOpaqueOf @LBS.ByteString -> Just s ] -> do
+          liftIO $ LBS.writeFile fn s
+
+        [StringLike fn, isOpaqueOf @ByteString -> Just s ] -> do
+          liftIO $ BS.writeFile fn s
+
+        _ -> throwIO (BadFormException @c nil)
+

lib/Data/Config/Suckless/Syntax.hs

@@ -4,15 +4,24 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# Language ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
 module Data.Config.Suckless.Syntax
   ( Syntax(..)
   , Id(..)
   , Literal(..)
+  , Opaque(..)
   , HasContext
   , C(..)
   , Context(..)
   , IsContext(..)
   , IsLiteral(..)
+  , ByteStringSorts(..)
+  , mkOpaque
+  , isOpaqueOf
+  , fromOpaque
+  , fromOpaqueThrow
+  , isByteString
+  , SyntaxTypeError(..)
   , pattern SymbolVal
   , pattern ListVal
   , pattern LitIntVal
@@ -20,27 +29,38 @@ module Data.Config.Suckless.Syntax
   , pattern LitBoolVal
   , pattern LitScientificVal
   , pattern StringLike
+  , pattern TextLike
   , pattern StringLikeList
   , pattern Nil
+  , pattern OpaqueVal
   )
   where
 
 import Data.Data
+import Data.Dynamic
 import Data.Kind
 import Data.String
 import Data.Text (Text)
 import Data.Scientific
 import GHC.Generics (Generic(..))
 import Data.Maybe
--- import GHC.Generics( Fixity(..) )
--- import Data.Data as Data
 import Data.Aeson
 import Data.Aeson.Key
 import Data.Aeson.KeyMap qualified as Aeson
 import Data.Vector qualified as V
 import Data.Traversable (forM)
 import Data.Text qualified as Text
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Function
+import Data.Functor
+import Control.Applicative
+import Control.Exception
+import Type.Reflection
+import Control.Monad.IO.Class
+import System.IO.Unsafe (unsafePerformIO)
+import Data.IORef
+import Data.Word
 
 import Prettyprinter
 
@@ -63,20 +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)
 
@@ -84,10 +113,25 @@ pattern StringLikeList e <- (stringLikeList -> e)
 pattern Nil :: forall {c} . Syntax c
 pattern Nil <- ListVal []
 
-
+pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
+pattern OpaqueVal box <- OpaqueValue box
 
 data family Context c :: Type
 
+isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
+isOpaqueOf = \case
+ OpaqueValue box -> fromOpaque @a box
+ _ -> Nothing
+
+isByteString :: Syntax c -> Maybe ByteStringSorts
+isByteString = \case
+  OpaqueValue box -> do
+    let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy
+    let bs = fromOpaque @ByteString box <&> ByteStringStrict
+    lbs <|> bs
+
+  _ -> Nothing
+
 class IsContext c where
   noContext :: Context c
 
@@ -103,9 +147,66 @@ 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)
+
+data Opaque = forall a. ForOpaque a =>
+  Opaque
+  { opaqueProxy :: !(Proxy a)
+  , opaqueId    :: !Word64
+  , opaqueRep   :: !SomeTypeRep
+  , opaqueDyn   :: !Dynamic
+  }
+
+opaqueIdIORef :: IORef Word64
+opaqueIdIORef = unsafePerformIO (newIORef 1)
+{-# NOINLINE opaqueIdIORef #-}
+
+mkOpaque :: forall c a m . (MonadIO m, ForOpaque a) => a -> m (Syntax c)
+mkOpaque x = do
+  n <- liftIO $ atomicModifyIORef opaqueIdIORef (\n -> (succ n,n))
+  pure $ OpaqueValue $ Opaque (Proxy :: Proxy a) n (someTypeRep (Proxy :: Proxy a)) (toDyn x)
+
+data SyntaxTypeError =
+  UnexpectedType String
+  deriving stock (Show,Typeable)
+
+instance Exception SyntaxTypeError
+
+fromOpaque :: forall a. Typeable a => Opaque -> Maybe a
+fromOpaque (Opaque{..}) = fromDynamic opaqueDyn
+
+fromOpaqueThrow :: forall a m . (MonadIO m, Typeable a) => String -> Opaque -> m a
+fromOpaqueThrow s (Opaque{..}) = do
+  let o = fromDynamic @a opaqueDyn
+  liftIO $ maybe (throwIO (UnexpectedType s)) pure o
+
+instance Eq Opaque where
+  (Opaque p1 _  t1 d1) == (Opaque _ _ t2 d2) =
+    t1 == t2 && unpack p1 d1 == unpack p1 d2
+    where
+      unpack :: forall a . (Typeable a) => Proxy a -> Dynamic -> Maybe a
+      unpack _ = fromDynamic @a
+
+-- Partial Data implementation for Opaque
+instance Data Opaque where
+  gfoldl _ z (Opaque{..}) = z (Opaque{..})
+
+  -- Can not be unfolded
+  gunfold _ z _ = z (Opaque (Proxy :: Proxy ()) 0 (someTypeRep (Proxy :: Proxy ())) (toDyn ()))
+
+  toConstr _ = opaqueConstr
+  dataTypeOf _ = opaqueDataType
+
+opaqueConstr :: Constr
+opaqueConstr = mkConstr opaqueDataType "Opaque" [] Prefix
+
+opaqueDataType :: DataType
+opaqueDataType = mkDataType "Opaque" [opaqueConstr]
+
+
 data Literal =
     LitStr   Text
   | LitInt   Integer
@@ -141,13 +242,14 @@ data Syntax c
   = List    (Context c) [Syntax c]
   | Symbol  (Context c) Id
   | Literal (Context c) Literal
+  | OpaqueValue Opaque
   deriving stock (Generic,Typeable)
 
-
 instance Eq (Syntax c) where
   (==) (Literal _ a) (Literal _ b) = a == b
   (==) (Symbol _ a)  (Symbol _ b) = a == b
   (==) (List _ a)    (List _ b) = a == b
+  (==) (OpaqueValue a) (OpaqueValue b) = a == b
   (==) _ _ = False
 
 deriving instance (Data c, Data (Context c)) => Data (Syntax c)
@@ -157,6 +259,7 @@ instance Pretty (Syntax c) where
   pretty (Symbol _ s)    = pretty s
   pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) )
   pretty (List _ [])     = parens mempty
+  pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v)
 
 instance Pretty Literal where
   pretty = \case
@@ -175,6 +278,7 @@ instance ToJSON Literal where
     toJSON (LitBool b)      = Bool b
 
 instance ToJSON (Syntax c) where
+    toJSON (OpaqueValue{}) = Null
     toJSON (Symbol _ (Id "#nil")) = Null
     toJSON (Symbol _ (Id s)) = String s
     toJSON (Literal _ l) = toJSON l

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