packages feed

suckless-conf (empty) → 0.1.2.9

raw patch · 23 files changed

+5649/−0 lines, 23 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, filepath, filepattern, hashable, hspec, html-entities, ini, interpolatedstring-perl6, microlens-platform, mtl, prettyprinter, prettyprinter-ansi-terminal, random, random-shuffle, safe, scientific, split, stm, streaming, suckless-conf, tasty-hunit, temporary, text, time, toml-parser, transformers, typed-process, uniplate, unliftio, unordered-containers, uuid, vector, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,23 @@+# Revision history for suckless-conf++## 0.1.2.9  2026-06-08++First Hackage release. Previously this package only lived as a+vendored subtree inside the `hbs2` repository; the source moves to+`github.com/NCrashed/suckless-conf` for independent maintenance.++  - No behavioural changes from the vendored 0.1.2.9.+  - The s-expression tokenizer and reader (`Data.Text.Fuzzy.Tokenize`+    and `Data.Text.Fuzzy.SExp`) are now bundled as internal modules,+    folded in from the `fuzzy-parse` package (MIT) with the local+    fixes this package depends on; the external `fuzzy-parse`+    dependency is dropped.+  - `Data.Config.Suckless.Parse.Fuzzy` and+    `Data.Config.Suckless.Script.Internal` moved from internal+    `other-modules` to `exposed-modules` so Hackage consumers can+    import them.+  - Cabal metadata filled in: synopsis, description, homepage,+    bug-reports, source-repository, `tested-with`, explicit version+    bounds on every dependency.+  - Maintainer is now `Anton Gushcha <ncrashed@gmail.com>`; original+    authorship by Dmitry Zuykov is preserved.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Dmitry Zuikov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Dmitry Zuikov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ LICENSE.fuzzy-parse view
@@ -0,0 +1,24 @@+The modules Data.Text.Fuzzy.Tokenize and Data.Text.Fuzzy.SExp are+derived from the fuzzy-parse package (https://github.com/hexresearch/fuzzy-parse)+and are distributed under the MIT license reproduced below.++Copyright (c) 2019 Dmitry Zuikov++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,41 @@+# suckless-conf++A small Lisp-like / s-expression configuration language with an+embedded scripting layer, plus `bf6`, its standalone script runtime.++## What it does++`suckless-conf` parses s-expression configuration files into a simple+`Syntax` tree (`Data.Config.Suckless.Syntax`, `.Parse`), exposes a+key-value access layer (`.KeyValue`) and bridges to Aeson, TOML, YAML+and INI. The same syntax doubles as a scripting language evaluated by+a tiny interpreter (`Data.Config.Suckless.Script`), and the package+installs the `bf6` executable that runs such scripts directly (for+example via a `#!` shebang).++## Modules++- `Data.Config.Suckless` - umbrella re-export.+- `Data.Config.Suckless.Syntax`, `.Parse`, `.Parse.Fuzzy` - the reader.+- `Data.Config.Suckless.KeyValue` - key-value access.+- `Data.Config.Suckless.Script`, `.Script.File`, `.Script.Internal` - the interpreter and `bf6` building blocks.+- `Data.Config.Suckless.System`, `.Almost.RPC` - helpers.++## Where it came from++Originally written by Dmitry Zuykov (voidlizard) inside the+[`hbs2`](https://github.com/NCrashed/hbs2) project. This Hackage+release is published from `github.com/NCrashed/suckless-conf` so+downstream projects can depend on it without vendoring.++The s-expression tokenizer and reader (`Data.Text.Fuzzy.Tokenize` and+`Data.Text.Fuzzy.SExp`) are derived from the+[`fuzzy-parse`](https://github.com/hexresearch/fuzzy-parse) package+(MIT) and bundled here as internal modules, carrying local fixes that+`suckless-conf` depends on.++## License++BSD-3-Clause for the `suckless-conf` code (see `LICENSE`); the bundled+`Data.Text.Fuzzy.*` modules are MIT (see `LICENSE.fuzzy-parse`).+Copyright holders are listed in the cabal file.
+ bf6/Main.hs view
@@ -0,0 +1,74 @@+{-# Language AllowAmbiguousTypes #-}+{-# Language UndecidableInstances #-}+module Main where++import Data.Config.Suckless.Script+import Data.Config.Suckless.Script.File as SF++import Safe+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++        hidden do+          entry $ bindMatch "#!" $ nil_ $ const do+            pure ()++  case cli of++    [ListVal (SymbolVal "#!" :_)] -> do+      pure ()++    [ListVal [SymbolVal "--run", StringLike fn]] -> do+      what <- liftIO $ readFile fn+                >>= either (error.show) pure . parseTop++      run dict what >>= eatNil display++    [ListVal [SymbolVal "stdin"]] -> do+      what <- liftIO getContents+                >>= either (error.show) pure . parseTop++      run dict what >>= eatNil display++    [ListVal (SymbolVal "file" : s@(StringLike fn : args))] -> do+      what <- liftIO (IO.readFile fn)+                >>= either (error.show) pure . parseTop++      runM dict do+        bindCliArgs s+        void $ evalTop what++    [] -> 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+
+ lib/Data/Config/Suckless.hs view
@@ -0,0 +1,12 @@+module Data.Config.Suckless+  ( module Data.Config.Suckless.Syntax+  , module Data.Config.Suckless.Parse+  , module Data.Config.Suckless.KeyValue+  )+  where++import Data.Config.Suckless.Syntax+import Data.Config.Suckless.Parse+import Data.Config.Suckless.KeyValue++
+ lib/Data/Config/Suckless/Almost/RPC.hs view
@@ -0,0 +1,118 @@+{-# 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.Text (Text)+import Data.Typeable+import Prettyprinter+import System.Process.Typed++import System.IO++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+  let what = proc name params & setStdin input+  (code, i, o) <- readProcess what++  unless (code == ExitSuccess) do+    liftIO $ hPrint stderr ( pretty $ LBS8.unpack o )+    liftIO $ throwIO (CallProcException code)++  let s = TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i)++  parseTop s & either (liftIO . throwIO) pure+++-- FIXME: to-suckless-script+callProcRaw :: forall m . MonadIO m+         => FilePath+         -> [String]+         -> m Text++callProcRaw name params  = 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+  let what = proc name params & setStdin closed+  (code, i, o) <- readProcess what++  unless (code == ExitSuccess) do+    liftIO $ hPrint stderr ( pretty $ LBS8.unpack o )+    liftIO $ throwIO (CallProcException code)++  let s = TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i)++  pure s+++runProcAttached :: forall m . MonadIO m+                => FilePath+                -> [String]+                -> m ExitCode+runProcAttached cmd args = do++  let processConfig = setStdout inherit+                    $ setStderr inherit+                    $ proc cmd args++  runProcess processConfig++runProcQuiet :: forall m . MonadIO m+                => FilePath+                -> [String]+                -> m ExitCode+runProcQuiet cmd args = do+  let config = setStdout createPipe $ setStderr createPipe  $ setStdout createPipe $ proc cmd args+  runProcess config++pipeProcText :: forall m . MonadIO m+         => FilePath+         -> [String]+         -> Text+         -> m Text++pipeProcText name params input' = do++  let input = LBS.fromStrict (TE.encodeUtf8 input')+                & byteStringInput+++  let what = proc name params & setStderr closed & setStdin input+  (code, i, o) <- readProcess what++  unless (code == ExitSuccess) do+    liftIO $ hPrint stderr ( pretty $ LBS8.unpack o )+    liftIO $ throwIO (CallProcException code)++  pure $ TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i)++
+ lib/Data/Config/Suckless/KeyValue.hs view
@@ -0,0 +1,111 @@+{-# Language PatternSynonyms #-}+{-# Language UndecidableInstances #-}+{-# Language AllowAmbiguousTypes #-}+module Data.Config.Suckless.KeyValue where++import Data.Config.Suckless.Syntax++import Data.String (IsString(..))+import Data.Set qualified as Set+import Data.Set (Set)+import Data.Maybe+import Data.Scientific+import Data.Aeson+import Prettyprinter+import Control.Monad.Reader+import Control.Monad.Identity+import Safe++import Debug.Trace++class  HasCfgKey a b where+  -- type family CfgValue a :: Type+  key :: Id++class Monad m => HasCfgValue a b m where+  cfgValue :: m b++class Monad m => HasConf m where+  getConf :: m [Syntax C]++pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]+pattern Key n ns <- SymbolVal  n : ns++instance {-# OVERLAPPABLE #-} (Monad m) => HasConf (ReaderT [Syntax C] m) where+  getConf = ask++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer)) => HasCfgValue a (Maybe Integer) m where+  cfgValue = lastMay . val <$> getConf+    where+      val syn = [ e+                | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer)+                ]+++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Int)) => HasCfgValue a (Maybe Int) m where+  cfgValue = lastMay . val <$> getConf @m+    where+      val syn = [ fromIntegral e+                | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Int)+                ]++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific)) => HasCfgValue a (Maybe Scientific) m where+  cfgValue = lastMay . val <$> getConf+    where+      val syn = [ e+                | ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific)+                ]++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool)) => HasCfgValue a (Maybe Bool) m where+  cfgValue = lastMay . val <$> getConf+    where+      val syn = [ e+                | ListVal (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool)+                ]++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value)) => HasCfgValue a (Maybe Value) m where+  cfgValue = lastMay . val <$> getConf+    where+      val syn = [ toJSON v+                | ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value)+                ]++instance {-# OVERLAPPABLE #-} (HasConf m, IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) m where+  cfgValue = lastMay . val <$> getConf+    where+      val syn = [ fromString (show $ pretty e)+                | ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)+                ]+++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer)) => HasCfgValue a (Set Integer) m where+  cfgValue  = Set.fromList . val <$> getConf+    where+      val syn = [ e+                | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer)+                ]++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific)) => HasCfgValue a (Set Scientific) m where+  cfgValue  = Set.fromList . val <$> getConf+    where+      val syn = [ e+                | ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific)+                ]+++instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value)) => HasCfgValue a (Set Value) m where+  cfgValue  = Set.fromList . val <$> getConf+    where+      val syn = [ toJSON v+                | ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value)+                ]+++instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b)) => HasCfgValue a (Set b) m where+  cfgValue  = Set.fromList . val <$> getConf+    where+      val syn = [ fromString (show $ pretty e)+                | ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Set b)+                ]++
+ lib/Data/Config/Suckless/Parse.hs view
@@ -0,0 +1,8 @@+module Data.Config.Suckless.Parse+  ( module Data.Config.Suckless.Parse.Fuzzy+  ) where++import Data.Config.Suckless.Parse.Fuzzy+++
+ lib/Data/Config/Suckless/Parse/Fuzzy.hs view
@@ -0,0 +1,40 @@+module Data.Config.Suckless.Parse.Fuzzy+  ( ParseSExp(..)+  ) where++import Data.Config.Suckless.Syntax+import Data.Text.Fuzzy.SExp qualified as P+import Data.Text.Fuzzy.SExp (C0(..),SExpParseError,ForMicroSexp(..))++import Data.Functor+import Data.Text as Text+import Control.Monad.Except+import Control.Monad.Identity++class ParseSExp what where+  parseTop :: what -> Either SExpParseError [Syntax C]+  parseSyntax :: what -> Either SExpParseError (Syntax C)++instance ParseSExp Text where+  parseTop what = runIdentity (runExceptT (P.parseTop  what)) <&> fmap toSyntax+  parseSyntax txt = runIdentity (runExceptT (P.parseSexp txt)) <&> toSyntax++instance ParseSExp String where+  parseTop what = runIdentity (runExceptT (P.parseTop  (Text.pack what))) <&> fmap toSyntax+  parseSyntax txt = runIdentity (runExceptT (P.parseSexp (Text.pack txt))) <&> toSyntax++toSyntax :: P.MicroSexp C0 -> Syntax C+toSyntax = \case+ P.List_    co  a -> List (toContext co) (fmap toSyntax a)+ P.Symbol_  co  a -> Symbol (toContext co) (Id a)+ P.String_  co  a -> Literal (toContext co) (LitStr a)+ P.Boolean_ co  a -> Literal (toContext co) (LitBool a)+ P.Number_  co  v -> case v of+  P.NumInteger n  -> Literal (toContext co) (LitInt n)+  P.NumDouble n   -> Literal (toContext co) (LitScientific (realToFrac n))++toContext :: C0 -> Context C+toContext (C0 what) = SimpleContext (fromIntegral <$> what)+++
+ lib/Data/Config/Suckless/Script.hs view
@@ -0,0 +1,86 @@+{-# Language UndecidableInstances #-}+{-# Language PatternSynonyms #-}+{-# Language RecordWildCards #-}+module Data.Config.Suckless.Script+  ( module Exported+  , module Data.Config.Suckless.Script+  ) where++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+++{- HLINT ignore "Functor law" -}++helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m ()+helpList hasDoc p = do++  let match = maybe (const True) (Text.isPrefixOf . Text.pack) p++  d <- ask >>= readTVarIO+  let ks = [k | Id k <- List.sort (HM.keys d)+           , match k+           , docDefined (HM.lookup (Id k) d) || not hasDoc+           ]++  display_ $ vcat (fmap pretty ks)++  where+    docDefined (Just (Bind (Just Man{..}) _)) | not manHidden  = True+    docDefined _ = False++helpEntry :: MonadUnliftIO m => Id -> RunM c m ()+helpEntry what' = do++  found <- flip fix what' $ \next what -> do+    ask >>= readTVarIO+       <&> HM.lookup what+       <&> (bindMan =<<)+       >>= \case+        Nothing -> pure Nothing+        Just (Man{manIsAliasFor = Just x, manBrief = Nothing}) -> next x+        Just x -> pure (Just ( x { manName = Just (ManName what') } ))++  liftIO $ hPutDoc stdout (pretty found)++pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]+pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]++pattern MatchOption:: forall {c} . Id -> Syntax c -> Syntax c+pattern MatchOption n e <- ListVal [SymbolVal n, e]++pattern MatchFlag :: forall {c} . Id -> Syntax c+pattern MatchFlag n  <- ListVal [SymbolVal n]++splitOpts :: forall c . IsContext c+          => [(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 view
@@ -0,0 +1,128 @@+{-# Language MultiWayIf #-}+module Data.Config.Suckless.Script.File where++import Data.Config.Suckless+import Data.Config.Suckless.Script.Internal++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont+import Data.Maybe+import Data.Either+import Data.Foldable+import System.Directory+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+import Streaming.Prelude qualified as S+++-- FIXME: skip-symlink+globSafer :: forall m . MonadIO m+     => [FilePattern]           -- ^ search patterns+     -> [FilePattern]           -- ^ ignore patterns+     -> FilePath                -- ^ directory+     -> (FilePath -> m Bool)    -- ^ file action+     -> m ()++globSafer pat ignore dir action = do+  q <- newTBQueueIO 1000+  void $ liftIO (async $ go q dir >> atomically (writeTBQueue q Nothing))+  fix $ \next -> do+    atomically (readTBQueue q) >>= \case+      Nothing -> pure ()+      Just x -> do+        r <- action x+        when r next++  where++    matches p f = or [ i ?== f | i <- p ]+    skip p = or [ i ?== p | i <- ignore ]++    go q f = do++      isD <- doesDirectoryExist f++      if not isD then do+        isF <- doesFileExist f+        when (isF && matches pat f && not (skip f)) do+          atomically $ writeTBQueue q (Just f)+      else do+        co' <- (try @_ @IOError $ listDirectory f)+                 <&> fromRight mempty++        pooledForConcurrentlyN_ 4 co' $ \x -> do+          let p = normalise (f </> x)+          unless (skip p) (go q p)+++-- FIXME: skip-symlink+glob :: forall m . MonadIO m+     => [FilePattern]           -- ^ search patterns+     -> [FilePattern]           -- ^ ignore patterns+     -> FilePath                -- ^ directory+     -> (FilePath -> m Bool)    -- ^ file action+     -> m ()++glob pat ignore dir action = do+  q <- newTQueueIO+  void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing))+  fix $ \next -> do+    atomically (readTQueue q) >>= \case+      Nothing -> pure ()+      Just x -> do+        r <- action x+        when r next++  where++    matches p f = or [ i ?== f | i <- p ]+    skip p = or [ i ?== p | i <- ignore ]++    go q f = do++      isD <- doesDirectoryExist f++      if not isD then do+        isF <- doesFileExist f+        when (isF && matches pat f && not (skip f)) do+          atomically $ writeTQueue q (Just f)+      else do+        co' <- (try @_ @IOError $ listDirectory f)+                 <&> fromRight mempty++        forConcurrently_ co' $ \x -> do+          let p = normalise (f </> x)+          unless (skip p) (go q p)++entries :: forall c m . ( IsContext c+                        , Exception (BadFormException c)+                        , MonadUnliftIO m)+         => MakeDictM c m ()+entries = do+  entry $ bindMatch "glob" $ \syn -> do++    (p,i,d) <- case syn of+                 [] -> pure (["**/*"], ["**/.*"], ".")++                 s@[StringLike d, ListVal (StringLikeList i) ] -> do+                    pure (i, [], d)++                 s@[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e) ] -> do+                    pure (i, e, d)++                 _ -> throwIO (BadFormException @c nil)++    r <- S.toList_ $ glob p i d $ \fn -> do+          S.yield (mkStr @c fn) -- do+          pure True++    pure (mkList r)+
+ lib/Data/Config/Suckless/Script/Internal.hs view
@@ -0,0 +1,2810 @@+{-# Language AllowAmbiguousTypes #-}+{-# Language UndecidableInstances #-}+{-# Language PatternSynonyms #-}+{-# Language ViewPatterns #-}+{-# Language RecordWildCards #-}+{-# Language MultiWayIf #-}+module Data.Config.Suckless.Script.Internal+  ( module Data.Config.Suckless.Script.Internal+  , module Export+  ) where++import Data.Config.Suckless+import Data.Config.Suckless.Syntax+import Data.Config.Suckless.Parse.Fuzzy as P+import Data.Config.Suckless.Almost.RPC+import Data.Config.Suckless.System++import Data.Traversable+import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Aeson as Aeson+import Data.Yaml qualified as Yaml+import Data.Ini qualified as Ini+import Data.Ini (Ini(..))+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.ByteString.Lazy.Char8 qualified as LBS8+import Data.Data+import Data.Coerce+import Data.Fixed+import Data.Foldable+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.Map qualified as Map+import Data.Kind+import Data.List (isPrefixOf)+import Data.List qualified as List+import Data.List ((\\))+import Data.List.Split (chunksOf)+import Data.Maybe+import Data.Either+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,encodeUtf8)+import Data.Text.Encoding.Error (ignore)+import Data.Time.Clock.POSIX+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.UUID.V4 qualified as UUID++import HTMLEntities.Text as Html+import GHC.Generics hiding (C)+import Prettyprinter+import Prettyprinter.Render.Terminal+import Safe+import Streaming.Prelude qualified as S+import System.Environment+import System.Directory qualified as Dir+import System.FilePath.Posix as P+import System.IO.Temp qualified as Temp+import System.Exit qualified as Exit+import System.Random as R+import System.Random.Shuffle (shuffleM)+import System.FilePattern+import Text.InterpolatedString.Perl6 (qc)+import Lens.Micro.Platform+import UnliftIO+import UnliftIO.Concurrent+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Maybe++-- TODO: move-to-suckless-conf++data ManApplyArg = ManApplyArg Text Text+                   deriving stock (Eq,Show,Data,Generic)++newtype ManApply = ManApply [ ManApplyArg ]+                   deriving stock (Eq,Show,Data,Generic)+                   deriving newtype (Semigroup,Monoid)++data ManSynopsis =+  ManSynopsis ManApply+  deriving stock (Eq,Show,Data,Generic)++data ManDesc     = ManDescRaw Text+  deriving stock (Eq,Show,Data,Generic)++data ManRetVal   = ManRetVal+  deriving stock (Eq,Show,Data,Generic)++newtype ManName a = ManName Id+  deriving stock (Eq,Show,Data,Generic)+  deriving newtype (IsString,Pretty)++newtype ManBrief = ManBrief Text+  deriving stock (Eq,Show,Data,Generic)+  deriving newtype (Pretty,IsString)++data ManReturns = ManReturns Text Text+  deriving stock (Eq,Show,Data,Generic)++newtype ManExamples =+  ManExamples Text+  deriving stock (Eq,Show,Data,Generic)+  deriving newtype (Pretty,IsString,Monoid,Semigroup)++class ManNameOf a ann where+  manNameOf :: a -> ManName ann++data Man a =+  Man+  { manName       :: Maybe (ManName a)+  , manHidden     :: Bool+  , manBrief      :: Maybe ManBrief+  , manSynopsis   :: [ManSynopsis]+  , manDesc       :: Maybe ManDesc+  , manReturns    :: Maybe ManReturns+  , manExamples   :: [ManExamples]+  , manIsAliasFor :: Maybe Id+  }+  deriving stock (Eq,Show,Generic)++instance Monoid (Man a) where+  mempty = Man Nothing False Nothing mempty Nothing Nothing mempty Nothing++instance Semigroup (Man a) where+  (<>) a b = Man (manName b <|> manName a)+                 (manHidden b || manHidden a)+                 (manBrief b <|> manBrief a)+                 (manSynopsis a <> manSynopsis b)+                 (manDesc b <|> manDesc a)+                 (manReturns b <|> manReturns a)+                 (manExamples a <> manExamples b)+                 (manIsAliasFor b <|> manIsAliasFor a)++instance ManNameOf Id a where+  manNameOf = ManName+++instance Pretty ManDesc where+  pretty = \case+    ManDescRaw t -> pretty t++instance IsString ManDesc where+  fromString s = ManDescRaw (Text.pack s)++instance Pretty (Man a) where+  pretty e =   "NAME"+             <> line+             <> indent 4 (pretty (manName e) <> fmtBrief e)+             <> line+             <> fmtSynopsis+             <> fmtDescription+             <> retval+             <> fmtExamples+   where+    fmtBrief a = case manBrief a of+      Nothing -> mempty+      Just x  -> " - " <> pretty x++    retval = case manReturns e of+      Nothing -> mempty+      Just (ManReturns t s) ->+        line <> "RETURN VALUE" <> line+        <> indent 4 (+            if not (Text.null s) then+              (pretty t <> hsep ["","-",""] <> pretty s) <> line+            else pretty t )++    fmtDescription = line+      <> "DESCRIPTION" <> line+      <> indent 4 ( case manDesc e of+           Nothing -> pretty (manBrief e)+           Just x  -> pretty x)+      <> line++    fmtSynopsis = case manSynopsis e of+      [] -> mempty+      _  ->+           line+        <> "SYNOPSIS"+        <> line+        <> vcat (fmap synEntry (manSynopsis e))+        <> line++    fmtExamples = case manExamples e of+      [] -> mempty+      es -> line+        <> "EXAMPLES"+        <> line+        <> indent 4 ( vcat (fmap pretty es) )++    synEntry (ManSynopsis (ManApply [])) =+      indent 4 ( parens (pretty (manName e)) ) <> line++    synEntry (ManSynopsis (ManApply xs)) = do+      indent 4 do+        parens (pretty (manName e) <+>+         hsep [ pretty n | ManApplyArg t n <- xs ]  )+         <> line+         <> line+         <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]++stringLike :: Syntax c -> Maybe String+stringLike = \case+  LitStrVal s -> Just $ Text.unpack s+  SymbolVal (Id s) -> Just $ Text.unpack s+  _ -> Nothing++stringLikeList :: [Syntax c] -> [String]+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes++blobLike :: Syntax c -> Maybe ByteString+blobLike = \case+  LitStrVal s -> Just $ BS8.pack (Text.unpack s)+  ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)+  _ -> Nothing++pattern BlobLike :: forall {c} . ByteString -> Syntax c+pattern BlobLike s <- (blobLike -> Just s)++toSortable :: Syntax c -> Either Double Text+toSortable = \case+  LitIntVal n         -> Left (fromIntegral n)+  LitScientificVal n  -> Left (realToFrac n)+  LitBoolVal False    -> Left 0+  LitBoolVal True     -> Left 1+  LitStrVal s         -> Right s+  SymbolVal (Id s)    -> Right s+  ListVal es          -> Left (fromIntegral (length es))+  OpaqueValue box     -> Left 0+  _                   -> Left 0++class Display a where+  display :: MonadIO m => a -> m ()++instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where+  display = liftIO . print . pretty++instance IsContext c => Display (Syntax c) where+  display = \case+    LitStrVal s -> liftIO $ TIO.putStr s+    -- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty+    --   liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)+    -- ListVal [SymbolVal "blob", LitStrVal txt] -> do+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty+    --   liftIO $ print $ parens $ "blob:base58" <+> dquotes s+    x           -> liftIO $ putStr (show $ pretty x)++instance Display Text where+  display = liftIO . TIO.putStr++instance Display String where+  display = liftIO . putStr++display_ :: (MonadIO m, Show a) => a -> m ()+display_ = liftIO . print++{- HLINT ignore "Functor law" -}+++isNil :: forall c . IsContext c => Syntax c -> Bool+isNil = \case+  ListVal [] -> True+  _          -> False++isFalse :: forall c . IsContext c => Syntax c -> Bool+isFalse = \case+    Literal _ (LitBool False) -> True+    ListVal [] -> True+    _ -> False++isTrue :: forall c . IsContext c => Syntax c -> Bool+isTrue = not . isFalse++eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()+eatNil f = \case+  Nil -> pure ()+  x   -> void $ f x++class OptionalVal c b where+  optional :: b -> Syntax c -> b++instance IsContext c => OptionalVal c Int where+  optional d = \case+    LitIntVal x -> fromIntegral x+    _           -> d++hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c)+hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k]+++pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c+pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]++pattern LambdaArgs :: [Id] -> Syntax c+pattern LambdaArgs a <- (lambdaArgList -> Just a)++-- FIXME: detect-invalid-varags+lambdaArgList :: Syntax c -> Maybe [Id]++lambdaArgList (ListVal a) = sequence argz+  where+    argz = flip fmap a \case+      (SymbolVal x) -> Just x+      _             -> Nothing++lambdaArgList _ = Nothing++pattern ArgList :: [Id] -> [Syntax c]+pattern ArgList a <- (argList -> Just a)++argList :: [Syntax c] -> Maybe [Id]+argList syn = sequence argz+  where+    argz = flip fmap syn \case+      (SymbolVal x) | x `notElem` [".","_"] -> Just x+      _                                     -> Nothing+++pattern PairList :: [Syntax c] -> [Syntax c]+pattern PairList es <- (pairList -> es)+++pairList :: [Syntax c ] -> [Syntax c]+pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes++optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)]+optlist = reverse . go []+  where+    go acc ( TextLike i : b : rest ) = go ((Id i, b) : acc) rest+    go acc [ TextLike i ] = (Id i, nil) : acc+    go acc _ = acc+++isPair :: Syntax c -> Maybe (Syntax c)+isPair = \case+  e@(ListVal [_,_]) -> Just e+  _ -> Nothing++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+  { bindMan         :: Maybe (Man AnsiStyle)+  , bindAction      :: BindAction c m+  } deriving (Generic)++deriving newtype instance Hashable Id++newtype NameNotBoundException =+  NameNotBound Id+  deriving stock Show+  deriving newtype (Generic,Typeable)+++data BadFormException c = BadFormException (Syntax c)+                        | ArityMismatch (Syntax c)+                        | NotLambda (Syntax c)+                        | NotBuiltinLambda Id+                        | RuntimeError (Syntax c)+                        | TypeCheckError (Syntax c)++newtype BadValueException = BadValueException String+                            deriving stock Show+                            deriving newtype (Generic,Typeable)++instance Exception NameNotBoundException++instance IsContext c => Show (BadFormException c) where+  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy+  show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy+  show (NotLambda sy) = show $ "NotLambda" <+> pretty sy+  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy+  show (RuntimeError sy) = show $ "RuntimeError" <+> pretty sy+  show (NotBuiltinLambda sy) = show $ "NotBuiltinLambda" <+> pretty sy++instance Exception (BadFormException C)++instance Exception BadValueException++type Dict c m = HashMap Id (Bind c m)+++newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }+                     deriving newtype ( Applicative+                                      , Functor+                                      , Monad+                                      , MonadIO+                                      , MonadUnliftIO+                                      , MonadReader (TVar (Dict c m))+                                      )++instance MonadTrans (RunM c) where+  lift = RunM . lift++newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }+                          deriving newtype ( Applicative+                                           , Functor+                                           , Monad+                                           , MonadWriter (Dict c m)+                                           )++makeDict :: (IsContext c, Monad m) =>  MakeDictM c m () -> Dict c m+makeDict w = execWriter ( fromMakeDict w )++entry :: Dict c m  -> MakeDictM c m ()+entry = tell++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)++hideKeyPredicate :: (Id -> Bool) -> MakeDictM c m () -> MakeDictM c m ()+hideKeyPredicate p = censor $+  HM.mapWithKey \k b -> if p k then hide b else b++hidePrefix :: Text -> MakeDictM c m () -> MakeDictM c m ()+hidePrefix p = hideKeyPredicate \(Id k) -> Text.isPrefixOf p k++hidePrefixes :: [Text] -> MakeDictM c m () -> MakeDictM c m ()+hidePrefixes ps = hideKeyPredicate \(Id k) ->+  any (\p -> Text.isPrefixOf p k) ps++desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()+desc txt = censor (HM.map setDesc)+  where+    w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }+    setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x++brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()+brief txt = censor (HM.map setBrief)+  where+    w0 = mempty { manBrief = Just txt }+    setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x++returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()+returns tp txt = censor (HM.map setReturns)+  where+    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+    updatedMan = case w of+      Nothing -> mempty { manSynopsis = [synopsis] }+      Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }++noArgs :: MakeDictM c m () -> MakeDictM c m ()+noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))++arg :: Text -> Text -> ManApplyArg+arg = ManApplyArg+++args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()+args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))++opt :: Doc a -> Doc a -> Doc a+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.lines (Text.strip s))+    ex0 = mempty { manExamples = [ex] }+    setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x++splitForms :: [String] -> [[String]]+splitForms s0 = runIdentity $ S.toList_ (go mempty s0)+  where+    go acc ( "then" : rest ) = emit acc >> go mempty rest+    go acc ( "and" : rest ) = emit acc >> go mempty rest+    go acc ( x : rest ) | isPrefixOf "-"  x =  go ( x : acc ) rest+    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest+    go acc ( x : rest ) = go ( x : acc ) rest+    go acc [] = emit acc++    emit = S.yield . reverse++++evargs :: forall c m . ( IsContext c+                       , MonadUnliftIO m+                       , Exception (BadFormException c)+                       )+       => Dict c m+       -> [Syntax c]+       -> RunM c m [Syntax c]++evargs dict = mapM (eval' dict)++applyLambda :: forall c m . ( IsContext c+                            , MonadUnliftIO m+                            , Exception (BadFormException c)+                            )+            => [Id]+            -> Syntax c+            -> [Syntax c]+            -> RunM c m (Syntax c)+applyLambda decl body ev = do++  let (manda,opt) = List.break (== ".") decl++  when (length manda > length ev) do+    throwIO (ArityMismatch @c nil)++  tv <- ask+  d0 <- readTVarIO tv++  let (mandatory,optional) = splitAt (length manda) ev++  forM_ (zip decl mandatory) $ \(n,v) -> do+    bind n v++  forM_ (headMay (tailSafe opt)) $ \n -> do+    bind n (mkList optional)++  e <- eval body++  atomically $ writeTVar tv d0+  pure e++apply_ :: forall c m . ( IsContext c+                      , MonadUnliftIO m+                      , Exception (BadFormException c)+                      )+      => Syntax c+      -> [Syntax c]+      -> RunM c m (Syntax c)++apply_ s args = case s of+  ListVal [SymbolVal "builtin:lambda", SymbolVal n]  -> apply n args++  ListVal (SymbolVal "builtin:closure" : e : free) -> do+    apply_ e (free <> args)++  ListVal (SymbolVal "builtin:rclosure" : e : free) -> do+    apply_ e (args <> free)++  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++apply :: forall c m . ( IsContext c+                      , MonadUnliftIO m+                      , Exception (BadFormException c)+                      )+      => Id+      -> [Syntax c]+      -> RunM c m (Syntax c)++apply "quot" e = case e of+  [ x ] -> pure x+  _ -> throwIO $ BadFormException @c nil++apply "quasiquot" args = do+  mkList <$> mapM (evalQQ mempty) args++apply name args' = do+  what <- ask >>=  readTVarIO <&> HM.lookup name++  case bindAction <$> what of+    Just (BindLambda e) -> do+      e args'++    Just (BindValue e)  -> do+      apply_ e args'++    Just (BindMacro macro) -> do+      macro args'++    Just (BindValue _) -> do+      throwIO (NotLambda (mkSym @c name))++    Nothing -> throwIO (NameNotBound name)++bind :: forall c m . ( IsContext c+                     , MonadUnliftIO m+                     , Exception (BadFormException c)+                     )+     => Id+     -> Syntax c+     -> RunM c m ()+bind name expr = do+  t <- ask++  what <- case expr of+           ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do+             m <- readTVarIO t+             HM.lookup n m & maybe (throwIO (NameNotBound n)) pure++           e -> pure $ Bind mzero (BindValue e)++  atomically do+    modifyTVar t (HM.insert name what)++bindBuiltins ::  forall c m . ( IsContext c+                              , MonadUnliftIO m+                              , Exception (BadFormException c)+                              )+            => Dict c m+            -> RunM c m ()++bindBuiltins  dict = do+  t <- ask+  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++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)+                     )+                       => Syntax c+                       -> RunM c m (Syntax c)+eval = eval' mempty+++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++    -- display_ $ "EVAL:" <+> pretty syn'++    dict1 <- ask >>= readTVarIO++    let dict = dict1 <> dict0++    -- liiftIO $ print $ show $ "TRACE EXP" <+> pretty syn+    let importDecls = HS.fromList [ "import", "define", "define-macro" :: Id ]++    let isDefine x = x == "define" || x == "local"++    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 ",@", x] -> do+        eval x++      ListVal [ SymbolVal "`", ListVal b] -> do+        mkList <$> (unsplice b >>= mapM (evalQQ dict))++      ListVal [ SymbolVal "quasiquot", ListVal b] -> do+        mkList <$> (mapM (evalQQ dict) =<< unsplice b)++      ListVal [ SymbolVal "quot", b] -> do+        pure b++      ListVal [ SymbolVal "eval", e ] -> eval e >>= eval++      ListVal [ SymbolVal "import", e ] -> do++        fn <- eval e >>= \case+                StringLike x -> pure x+                _            -> throwIO (BadFormException @c syn')++        let importsName = "*runtime-imports*"+        let alreadyError = RuntimeError $ mkForm "runtime-error" [ mkStr @c ["already imported", pretty fn] ]+        let disappearedMessage = [mkStr @c [coerce importsName, "misteriously disappeared" :: Text]]+        let disappeared = RuntimeError $ mkForm "runtime-error" disappearedMessage++        initial <- newTVarIO (mempty :: HashMap Id (HashSet Id)) >>= mkOpaque++        imp_ <- lookupValueDef initial importsName >>= \case+                   OpaqueVal e -> fromOpaque @(TVar (HashMap Id (HashSet Id))) e & \case+                                    Just x  -> pure x+                                    Nothing -> throwIO disappeared++                   _           -> throwIO (RuntimeError (mkStr @c $ show $ pretty importsName <> "misteriously disappeared"))+++        seen <- atomically $ stateTVar imp_ (\e -> (HM.lookup (mkId fn) e, HM.insert (mkId fn) mempty e))++        -- liftIO $ print $ pretty "import" <+> pretty fn++        -- TODO: maybe-should-be-error+        case seen of+          Just{} -> pure nil+          Nothing{} -> do++            -- FIXME: fancy-error-handling+            syn <- liftIO (TIO.readFile fn) <&> parseTop >>= either(error.show) pure++            let decls = [ fixContext d+                        | d@(ListVal (SymbolVal what : rest)) <- syn+                        , what `HS.member` importDecls+                        ]++            void $ evalTop decls++            pure nil++      ListVal [SymbolVal def, SymbolVal what, e] | isDefine def -> 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++      w@(ListVal (SymbolVal "fn" : a@(SymbolVal{}) : rest)) -> do+        let dot = mkSym "."+        let (aa, body') = List.break (== dot) rest+                              & over _2  (List.dropWhile (==dot))++        args <- argList (a:aa) & \case+                  Nothing -> throwIO (BadFormException @c w)+                  Just xs -> pure xs++        body <- case body' of+                  [e] -> pure e+                  es  -> pure $ mkList es++        pure $ mkForm @c "lambda" [ mkList (fmap mkSym args), body ]++      ListVal [SymbolVal "fn", LitIntVal n, body] -> do+        pure $ mkForm @c "lambda" [ mkList [ mkSym ("_" <> show i) | i <- [1..n]  ], body ]++      ListVal (SymbolVal "fn1" : body) -> do+        let e = case body of+                  [e] -> e+                  es  -> mkList es++        pure $ mkForm @c "lambda" [ mkList [ mkSym "_1"  ], e ]++      ListVal [SymbolVal "lambda", arglist, body] -> do+        pure $ mkForm @c "lambda" [ arglist, body ]++      ListVal [SymbolVal def, LambdaArgs (name : args), e] | isDefine def -> do+        bind name ( mkForm @c  "lambda" [ mkList [ mkSym s | s <- args], e ] )+        pure nil++      ListVal [SymbolVal "false?", e'] -> do+        e <- eval e'+        pure $ if isFalse e then mkBool True else mkBool False++      ListVal [SymbolVal "if", w, e] -> do+        what <- eval w+        if not (isFalse what) then eval e else pure nil++      ListVal [SymbolVal "if", w, e1, e2] -> do+        what <- eval w+        if isFalse what then eval e2 else eval e1++      ListVal [SymbolVal "unless", w, e1] -> do+        what <- eval w+        if isFalse what then eval e1 else pure nil++      ListVal (SymbolVal "begin" : what) -> do+        evalTop what++      e@(ListVal (SymbolVal "blob" : what)) -> do+        pure e++      r@(ListVal (SymbolVal "cond" : clauses)) -> do++        flip fix clauses $  \next -> \case++          (ListVal [SymbolVal "_", e1] : _) -> do+            eval e1++          (ListVal [p', e1] : rest) -> do++            p <- eval p'++            if isFalse p then+              next rest+            else do+              eval e1++          (_ : _) -> throwIO (BadFormException r)++          [] -> pure nil++      r@(ListVal (SymbolVal "match" : e' : clauses)) -> do+        e <- eval e'++        flip  runContT pure $ callCC \exit -> do++          for_ clauses $ \case++            ListVal [ SymbolVal "_" , e1' ] -> do+              e1 <- lift (eval e1')+              -- error $ show $ "SHIT MATCHED" <+> pretty e1+              exit e1++            ListVal [ p, e1' ] -> do+              lift (matchPattern p e e1') >>= \case+                Nothing  -> pure ()+                Just m   -> exit m++            _ -> pure ()++          pure nil+++      lc@(ListVal (Lambda decl body : args))  -> do+        applyLambda decl body =<< evargs dict args++      ListVal (SymbolVal name : args') -> do+        apply name =<< evargs dict args'++      ListVal (e' : args') -> do+        e <- eval e'+        apply_ e =<< evargs dict args'++      SymbolVal name | HM.member name dict -> do+++        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@OpaqueValue{} -> pure e++      e -> do+        throwIO $ NotLambda @c e++  where+    handleForm syn = \case+      (BadFormException _  :: BadFormException c) -> 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+                      , Exception (BadFormException c)+                      ) => Dict c m -> RunM c m a ->  m a+runM  d  m = do+  tvd <- newTVarIO d+  runReaderT (fromRunM m) tvd++runTM :: forall c m a. ( IsContext c+                      , MonadUnliftIO m+                      , Exception (BadFormException c)+                      ) => TVar (Dict c m) -> RunM c m a ->  m a+runTM  tvd  m = do+  runReaderT (fromRunM m) tvd++run :: forall c m . ( IsContext c+                    , MonadUnliftIO m+                    , Exception (BadFormException c)+                    ) => Dict c m -> [Syntax c] -> m (Syntax c)+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))+     => [Syntax c]+     -> RunM c m (Syntax c)+evalTop syn = lastDef nil <$> mapM eval syn++bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m+bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))+  where+    man = Just $ mempty { manName = Just (manNameOf n) }++{- HLINT ignore "Redundant <&>" -}++bindAlias :: forall c m . ( MonadUnliftIO m+                          , IsContext c+                          , Exception (BadFormException c))+          => Id -> Id  -> Dict c m+bindAlias n fn = HM.singleton n (Bind man (BindLambda callAlias))+  where+    man = Just $ mempty { manName = Just (manNameOf n), manIsAliasFor = Just fn }+    callAlias syn = do+      ask  >>= readTVarIO+           <&> (fmap bindAction . HM.lookup fn)+           >>= \case+              Just (BindLambda la) -> la syn+              _  -> throwIO (NotBuiltinLambda @c fn)++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)++lookupValueDef :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m)+               => Syntax c+               -> Id+               -> RunM c m (Syntax c)+lookupValueDef defVal i = do+  ask  >>= readTVarIO+       <&> (fmap bindAction . HM.lookup i)+       >>= \case+          Just (BindValue s) -> pure s+          _  -> do+            bind i defVal+            pure defVal++nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)+nil_ m w = m w >> pure (List noContext [])+++unwrapped :: IsContext c => [Syntax c] -> Syntax c+unwrapped = \case+  []       -> nil+  [ e ]    -> e+  ( x:xs ) -> mkList (x:xs)++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++fixList :: forall c . IsContext c => Syntax c -> Syntax c+fixList = \case+  (ListVal es) -> mkList ( mkSym "list" : es )+  e -> e++fmt :: Syntax c -> Doc ann+fmt = \case+  LitStrVal x -> pretty $ Text.unpack x+  x -> pretty x++newtype IniConfig = IniConfig Ini.Ini++instance IsContext c => MkSyntax c IniConfig where+  mkSyntax (IniConfig  (Ini{..})) = do++    let section kvs = [ mkList [mkSym k, either (const (mkStr v)) fixContext (P.parseSyntax v)]+                      | (k,v) <- kvs+                      ]++    let globals = section iniGlobals++    let sections = [ mkForm @c s (section pps) | (s, pps)  <- HM.toList iniSections ]++    mkList (globals <> sections)++bindCliArgs :: forall c m . (IsContext c, MonadUnliftIO m, Exception (BadFormException c))+            => [Syntax c] -> RunM c m ()+bindCliArgs a = do+  bind "$*" (mkList a)+  bind "*args" (mkList a)+  forM_ (zip [1..] a) $ \(i,e) -> do+    bind (fromString ("$"<>show i)) e++internalEntries :: forall c m . ( IsContext c+                                , Exception (BadFormException c)+                                , MonadUnliftIO m) => MakeDictM c m ()+internalEntries = do++    entry $ bindValue "false"      (mkBool False)+    entry $ bindValue "true"       (mkBool True)+    entry $ bindValue "chr:semi"   (mkStr ";")+    entry $ bindValue "chr:tilda"  (mkStr "~")+    entry $ bindValue "chr:colon"  (mkStr ":")+    entry $ bindValue "chr:comma"  (mkStr ",")+    entry $ bindValue "chr:q"      (mkStr "'")+    entry $ bindValue "chr:minus"  (mkStr "-")+    entry $ bindValue "chr:dq"     (mkStr "\"")+    entry $ bindValue "chr:lf"     (mkStr "\n")+    entry $ bindValue "chr:cr"     (mkStr "\r")+    entry $ bindValue "chr:tab"    (mkStr "\t")+    entry $ bindValue "chr:space"  (mkStr " ")+    entry $ bindValue "chr:dot"    (mkStr ".")+    entry $ bindValue "dot"        (mkStr ".")++    entry $ bindAlias "local" "define"++    brief "concatenates list of string-like elements into a string"+      $ args [arg "list" "(list ...)"]+      $ args [arg "..." "..."]+      $ returns "string" ""+      $ examples [qc|+        (concat a b c d)+        abcd|]+      $ examples [qc|+        (concat 1 2 3 4 5)+        12345|]++      $ entry $ bindMatch "concat" (pure . mkStr . foldMap synToText)++    let mkJoin x es = do+         let xs = List.intersperse x es+         pure $ mkStr ( show $ hcat (fmap fmt xs) )++    entry $ bindMatch "join" $ \case+      [ x, ListVal es ] -> mkJoin x es+      (x : es ) -> mkJoin x es+      _ -> throwIO (BadFormException @C nil)++    brief "creates a list of elements"+      $ args [arg "..." "..."]+      $ returns "list" ""+      $ examples [qc|+(list 1 2 3 fuu bar "baz")+(1 2 3 fuu bar "baz")+      |]+      $ entry $ bindMatch "list" $ \case+        es -> do+          pure $ mkList es++    entry $ bindMatch "dict" $ \case+      (pairList -> es@(_:_)) -> do+        pure $ mkList es+      [a, b] -> do+        pure $ mkList [ mkList [a, b] ]+      _ -> throwIO (BadFormException @C nil)++    brief "creates a dict from a linear list of string-like items"+      $ args [arg "list-of-terms" "..."]+      $ desc (    "macro; syntax sugar" <> line+               <> "useful for creating function args" <> line+               <> "leftover records are skipped"+             )+      $ returns "dict" ""+      $ examples [qc|+[kw a 1 b 2 c 3]+(dict (a 1) (b 2) (c 3))++[kw a]+(dict (a ()))++[kw a b]+(dict (a b))++[kw 1 2 3]+(dict)++[kw a b c]+(dict (a b) (c ()))+      |]+      $ entry $ bindMatch "kw" $ \syn -> do+         let wat = mkList [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]+         pure $ wat++    entry $ bindMatch "iterate" $ nil_ $ \case+      [ what, ListVal es ] -> do+        mapM_ (apply_ what . List.singleton) es++      _ -> do+        throwIO (BadFormException @C nil)++    entry $ bindMatch "for" $ nil_ $ \case+      [ ListVal es, what ] -> do+        mapM_ (apply_ what . List.singleton) es++      _ -> do+        throwIO (BadFormException @C nil)++    entry $ bindMatch "replicate" $ \case+      [LitIntVal n, e] -> pure $ mkList (replicate (fromIntegral n) e)+      _ -> pure nil++    entry $ bindMatch "repeat" $ nil_ $ \case+      [LitIntVal n, Lambda [] b] -> do+        replicateM_ (fromIntegral n) (applyLambda [] b [])++      [LitIntVal n, e@(ListVal _)] -> do+        replicateM_ (fromIntegral n) (eval e)++      z ->+        throwIO (BadFormException @C nil)++    entry $ bindMatch "apply" $ \case+      [e, ListVal es] -> apply_ e es++      e -> throwIO (BadFormException @c (mkList e))++    entry $ bindMatch "eval" $ \syn -> do+      r <- mapM eval syn+      pure $ lastDef nil r++    entry $ bindMatch "curry" \case+      [e1, e2] -> pure $ mkForm "builtin:closure" [e1, e2]+      e -> throwIO (BadFormException @c  (mkList e))++    entry $ bindMatch "rcurry" \case+      [e1, e2] -> pure $ mkForm "builtin:rclosure" [e1, e2]+      e -> throwIO (BadFormException @c  (mkList e))++    entry $ bindMatch "id" $ \case+      [ e ] -> pure e+      _ -> throwIO (BadFormException @C nil)++    entry $ bindMatch "true?" $ \case+      [ e ] | e == mkBool True -> pure $ mkBool True+      _ -> pure $ mkBool False++    entry $ bindMatch "inc" $ \case+      [ LitIntVal n ] -> pure (mkInt (succ n))+      _ -> throwIO (TypeCheckError @C  nil)++    entry $ bindMatch "dec" $ \case+      [ LitIntVal n ] -> pure (mkInt (pred n))+      _ -> throwIO (TypeCheckError @C  nil)++    entry $ bindMatch "map" $ \case+      [ what, ListVal es ] -> do+        mkList <$> mapM (apply_ what . List.singleton) es++      _ -> do+          throwIO (BadFormException @C nil)++    entry $ bindMatch "for" $ \case+      [ ListVal es, what ] -> do+        mkList <$> mapM (apply_ what . List.singleton) es++      e -> throwIO (BadFormException @c (mkList e))++    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 "last" $ \case+      [ ListVal es ] -> pure (lastDef nil es)+      [ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (lastMay es)+      _ -> throwIO (TypeCheckError @C nil)++    entry $ bindMatch "head" $ \case+      [ ListVal es ] -> pure (headDef nil es)+      [ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (headMay es)+      _ -> throwIO (TypeCheckError @C nil)++    entry $ bindAlias "car" "head"++    brief "get tail of list"+      $ args [arg "list" "list"]+      $ desc "nil if the list is empty; error if not list"+      $ examples [qc|+      (tail [list 1 2 3])+      (2 3)+      (tail [list])+      |]+      $ entry $ bindMatch "tail" $ \case+        [] -> pure nil+        [ListVal []] -> pure nil+        [ListVal es] -> pure $ mkList  (tail es)++        [StringLike es] -> pure $ case tailSafe es  of+                                    [] -> nil+                                    xs -> mkSym xs++        _ -> throwIO (BadFormException @c nil)++    entry $ bindAlias "cdr" "tail"++    entry $ bindMatch "cons" $ \case+      [ e, ListVal es ] -> pure (mkList (e:es))+      _ -> throwIO (BadFormException @C nil)++    entry $ bindMatch "@" $ \syn -> do+      case List.uncons (reverse syn) of+        Nothing -> pure nil+        Just (a, []) -> pure a+        Just (a, fs) -> flip fix (a, fs) $ \next -> \case+          (acc, []) -> pure acc+          (acc, x:xs) -> do+            acc' <- apply_ x [acc]+            next (acc', xs)++    entry $ bindMatch "void" $ nil_ $ const $ pure ()++    entry $ bindMatch "split" $ \case+      [TextLike sep, TextLike s] ->+        pure $ mkList [mkStr x | x <- Text.splitOn sep s]++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "filter" $ \case+      [pred, ListVal xs] -> do+        filtered <- flip filterM xs $ \x -> do+          res <- apply_ pred [x]+          case res of+            LitBoolVal True -> pure True+            _ -> pure False++        pure $ mkList filtered++      _ -> throwIO (BadFormException @c nil)+++    entry $ bindMatch "list:chunks" $ \case+      [ LitIntVal n, ListVal xs ] -> do+        pure $ mkList [ mkList es | es <- chunksOf (fromIntegral n) xs ]++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "group-by" $ \case+      [cmp, ListVal es] -> do+        let groupByM _ [] = pure []+            groupByM eq (x:xs) = do+              (same, rest) <- partitionM (eq x) xs+              groups <- groupByM eq rest+              pure ((x:same) : groups)++        let eqFunc a b = do+              result <- apply_ cmp [a, b]+              pure $ case result of+                LitBoolVal v -> v+                _ -> False  -- Если не bool, считаем, что не равны++        grouped <- groupByM eqFunc es+        pure $ mkList [mkList group | group <- grouped]++      _ -> throwIO (BadFormException @c nil)+++    entry $ bindMatch "sort-with" $ \case+      [cmp, ListVal es] -> do+        let cmpFunc a b = do+              result <- apply_ cmp [a, b]+              pure $ case result of+                LitBoolVal v -> v+                _ -> False  -- Если не bool, считаем `x < y` ложным++        sorted <- sortByM cmpFunc es+        pure $ mkList sorted++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "sort" $ \case+      [ListVal es] -> pure $ mkList $ (List.sortOn toSortable) es+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "sort-by" $ \case+      [what, ListVal es] -> do+        sorted <- forM es \e -> do+          key <- apply_ what [e]+          pure (key, e)++        pure $ mkList [e | (_, e) <- List.sortOn (toSortable . fst) sorted]++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "append" $ \syn -> do+      pure $ mkList $  flip fix (mempty, syn) $ \next (acc, terms) -> do+        case terms of+          [] -> acc+          (ListVal xs : rest) -> next (acc <> xs, rest)+          (other : rest) -> next (acc <> [other], rest)++    entry $ bindMatch "flatten" $ \case+      [ListVal es] -> pure $ mkList (concatMap flattenList es)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "reverse" $ \case+      [ListVal es] -> pure $ mkList (List.reverse es)+      [LitStrVal s] -> pure $ mkStr (Text.reverse s)+      [SymbolVal (Id s)] -> pure $ mkSym (Text.reverse s)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "nub" $ \case+      [ ListVal es ] -> pure $ mkList $ List.nub es+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "zip" $ \case+      [ ListVal a, ListVal b ] -> pure $ mkList (zipWith (\x y -> mkList [x,y]) a b)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "take" $ \case+      [ LitIntVal n, ListVal es ] -> pure $ mkList $ take (fromIntegral n) es+      [ LitIntVal n, StringLike es ] -> pure $ mkStr $ take (fromIntegral n) es+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "drop" $ \case+      [ LitIntVal n, ListVal es ] -> pure $ mkList $ drop (fromIntegral n) es+      [ LitIntVal n, StringLike es ] -> pure $ mkStr $ drop (fromIntegral n) es+      _ -> throwIO (BadFormException @c nil)+++    entry $ bindMatch "nth" $ \case+      [LitIntVal i, ListVal es] -> do+        let idx = if i < 0 then length es + fromIntegral i else fromIntegral i+        pure $ atDef nil es idx++      [LitIntVal i, StringLike es] -> do+        let idx = if i < 0 then length es + fromIntegral i else fromIntegral i+        pure $ maybe nil (mkSym . List.singleton) $ atMay es idx++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "set!" $ nil_ $ \case+      [SymbolVal v, e] -> do+        -- tvd <- ask+        bind v e+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "assoc" $ \case+      [k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ]+      _ -> throwIO (BadFormException @c nil)+++    entry $ bindMatch "coalesce" $  \case+      [a] -> pure a+      [a,b] | isFalse b -> pure a+            | otherwise -> pure b+      _ -> pure nil++    entry $ bindAlias "nvl" "coalesce"++    --TODO: integral sum++    entry $ bindMatch "align" $  \syn -> do+      (n,f,s)  <- case syn of+                    [ LitIntVal n, TextLike s ] -> pure (n,' ',s)+                    [ LitIntVal n, TextLike f, TextLike s ] -> pure (n, maybe ' ' fst (Text.uncons f) ,s)+                    e -> throwIO (BadFormException @c (mkList e))++      let shift = fromIntegral $ abs n+      let fn = if n >= 0 then Text.justifyLeft else Text.justifyRight+      pure $ mkStr (fn shift f s)++    entry $ bindMatch "upper" $ \case+      [ LitStrVal x ] -> pure $ mkStr $ Text.toUpper x+      [ SymbolVal (Id x) ] -> pure $ mkStr $ Text.toUpper x+      _ -> pure nil++    entry $ bindMatch "lower" $ \case+      [ LitStrVal x ] -> pure $ mkStr $ Text.toLower x+      [ SymbolVal (Id x) ] -> pure $ mkStr  $ Text.toLower x+      _ -> pure nil++    entry $ bindMatch "words" $ \case+      [ TextLike x ] -> pure $ mkList [ mkStr  y | y <- Text.words x ]+      _ -> pure nil++    entry $ bindMatch "unwords" $ \case+      [ ListVal (TextLikeList xs) ] -> pure $ mkStr (Text.unwords xs)+      ( TextLikeList xs) -> pure $ mkStr (Text.unwords xs)+      _ -> pure $ mkStr ""++    entry $ bindMatch "lines" $ \case+      [ TextLike x ] -> pure $ mkList [ mkStr  y | y <- Text.lines x ]+      _ -> pure nil+++    entry $ bindMatch "unlines" $ \case+      [ ListVal (TextLikeList xs) ] -> pure $ mkStr (Text.unlines xs)+      ( TextLikeList xs) -> pure $ mkStr (Text.unwords xs)+      _ -> pure $ mkStr ""++    entry $ bindMatch "mod" $ \case+      [LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (mod a b)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindAlias "%" "mod"++    entry $ bindMatch "floor" $ \case+      [LitScientificVal x] ->+        pure $ mkInt (floor x)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "ceiling" $ \case+      [LitScientificVal x] ->+        pure $ mkInt (ceiling x)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "fixed" $ \case++      [LitIntVal 1, LitScientificVal x] -> do+        pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E1) x)++      [LitIntVal 2, LitScientificVal x] -> do+        pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E2) x)++      [LitIntVal 3, LitScientificVal x] -> do+        pure $ mkSym $ show $ (realToFrac $ realToFrac @_ @(Fixed E3) x)++      [LitIntVal 6, LitScientificVal x] -> do+        pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E6) x)++      [LitIntVal 9, LitScientificVal x] -> do+        pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E9) x)++      [LitIntVal 12, LitScientificVal x] -> do+        pure $ mkSym $ show  (realToFrac $ realToFrac @_ @(Fixed E12) x)++      [LitIntVal _, LitScientificVal x] -> do+        pure $ mkDouble x++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "round" $ \case++      [LitScientificVal x] -> do+        pure $ mkDouble (realToFrac $ floor x)++      [LitIntVal n, LitScientificVal x] -> do+        let factor = 10 ^ n+            rounded = fromIntegral (round (x * fromIntegral factor)) / fromIntegral factor+        pure (mkDouble rounded)++      _ -> throwIO (BadFormException @c nil)+++    entry $ bindMatch "sum" $ \x -> do+      ds <- case x of+              [ ListVal es ]  -> pure es+              es -> pure es++      let v = flip mapMaybe ds \case+                LitIntVal n         -> Just $ realToFrac  n+                LitScientificVal n  -> Just $ realToFrac @_ @Double n+                _ -> Nothing++      pure $ mkDouble $ sum v++    entry $ bindMatch "assoc:nth" $ \case+      [LitIntVal i, k, ListVal es ] -> do+        pure $ headDef nil [ r | r@(ListVal ys) <- es, atMay  ys (fromIntegral i) == Just k ]+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "unwrap" $ \case+      [ ListVal [one] ] -> pure one+      [ e ] -> pure e+      other  -> throwIO (BadFormException @c (mkList other))++    entry $ bindAlias "unw" "unwrap"++    entry $ bindMatch "lookup:uw" $ \case+      [k, ListVal es ] -> do+        let val = headDef nil [ unwrapped rest | ListVal (w:rest) <- es, k == w ]+        pure val++      [StringLike s, ListVal [] ] -> do+        pure nil++      _ -> throwIO (BadFormException @c nil)++    entry $ bindAlias "@?" "lookup:uw"++    entry $ bindMatch "lookup" $ \case+      [k, ListVal es ] -> do+        let val = headDef nil [ mkList rest | ListVal (w:rest) <- es, k == w ]+        pure val++      [StringLike s, ListVal [] ] -> do+        pure nil++      _ -> throwIO (BadFormException @c nil)+++    brief "returns current unix time"+      $ returns "int" "current unix time in seconds"+      $ noArgs+      $ entry $ bindMatch "now" $ \case+        [] -> mkInt . round <$> liftIO getPOSIXTime+        _  -> throwIO (BadFormException @c nil)++    entry $ bindMatch "display" $ nil_ \case+      [ 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++      _  -> throwIO (BadFormException @c nil)++    brief "prints new line character to stdout"+      $ entry $ bindMatch "newline" $ nil_ $ \case+          [] -> liftIO (putStrLn "")+          _  -> throwIO (BadFormException @c nil)++    brief "prints a list of terms to stdout"+      $ entry $ bindMatch "print" $ nil_ $ \case+          [ sy ] -> display sy+          ss     -> mapM_ display ss++    entry $ bindMatch "println" $ nil_ $ \case+      [ sy ] -> display sy >> liftIO (putStrLn "")+      ss     -> mapM_ display ss >> liftIO (putStrLn "")++    entry $ bindMatch "flush:stdout" $ nil_ $ \case+      [] -> liftIO do+        hFlush stdout++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "str:getchar:stdin" $ \case+      [] -> liftIO do+        hSetBuffering stdin NoBuffering+        mkStr . List.singleton <$> getChar++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "str:stdin" $ \case+      [] -> liftIO getContents <&> mkStr @c++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "str:put" $ nil_ $ \case+      [LitStrVal s] -> liftIO $ TIO.putStr s+      _ -> throwIO (BadFormException @c nil)++    brief "extracts columns from string"+     $ returns "[string]" "[fields]"+     $ desc [qc|+str:cut n str+  ; extracts column n       from str++str:cut a b str+  ; extracts columns a -- b from str++str:cut b a str+  ; extracts columns b -- a from str+  ; (like in previous case, but in reversed order)++str:cut '[a b c] str+  ; extracts columns a,b,c   from str+|]++     $ examples [qc|++$ echo A B C  | bf6 [str:cut [list 2 1] [str:stdin]]+("C B")++|]++     $ entry $ bindMatch "str:cut" $ \e -> do++        let extract :: Int -> Int -> [Text] -> [Text]+            extract a b =+              let extractLine line =+                    let ws = Text.words line+                        len = length ws+                        a' = a+                        b' = if b < 0 then len - 1 else b+                        lo = max 0 (min a' b')+                        hi = min len (max a' b' + 1)+                        piece = take (hi - lo) (drop lo ws)+                    in Text.unwords (if a' > b' then reverse piece else piece)+              in fmap extractLine++            extractOne :: Int -> [Text] -> [Text]+            extractOne n =+              let i = max 0 n+              in fmap \line -> atDef "" (Text.words line) i++            extractMany :: [Int] -> [Text] -> [Text]+            extractMany ns =+              fmap \line ->+                let ws = Text.words line+                    picked = [ atDef "" ws (max 0 i) | i <- ns ]+                in Text.unwords picked++            runCut range lines = do+              let out = case range of+                    Left n       -> extractOne n lines+                    Right (a,b)  -> extract a b lines+              pure $ mkList @c (fmap mkStr out)++            runCutList ns lines = do+              let out = extractMany ns lines+              pure $ mkList @c (fmap mkStr out)++        case e of+          -- Один индекс+          [LitIntVal n, ListVal (TextLikeList s)] ->+            runCut (Left (fromIntegral n)) s++          [LitIntVal n, TextLike s] ->+            runCut (Left (fromIntegral n)) (Text.lines s)++          -- Диапазон+          [LitIntVal a, LitIntVal b, ListVal (TextLikeList s)] ->+            runCut (Right (fromIntegral a, fromIntegral b)) s++          [LitIntVal a, LitIntVal b, TextLike s] ->+            runCut (Right (fromIntegral a, fromIntegral b)) (Text.lines s)++          -- Список колонок+          [ListVal (IntLikeList ns), ListVal (TextLikeList s)] ->+            runCutList (map fromIntegral ns) s++          [ListVal (IntLikeList ns), TextLike s] ->+            runCutList (map fromIntegral ns) (Text.lines s)++          _ -> throwIO (BadFormException @c nil)+++    brief "reads file as a string" do+      entry $ bindMatch "str:file" $ \case+        [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr++        _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "str:save" $ nil_ \case+      [StringLike fn, StringLike what] ->+        liftIO (writeFile fn what)++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "str:append:file" $ nil_ \case+      (StringLike fn : StringLikeList what) -> do+        liftIO (forM_ what (appendFile fn))++      e -> throwIO (BadFormException @c (mkList e))++    entry $ bindValue "space" $ mkStr " "++    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++    entry $ bindMatch "json" \case+      [ e ] -> pure $ mkStr $ LBS8.unpack $ Aeson.encode $ toJSON e+      x      -> pure $ mkStr $ LBS8.unpack $ Aeson.encode $ toJSON (mkList x)++    entry $ bindMatch "json:stdin" $ const do+      parseJson <$> liftIO (LBS.hGetContents stdin)++    entry $ bindMatch "json:file" $ \case+      [StringLike fn] -> do+        parseJson <$>  liftIO (LBS.readFile fn)++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "json:string" $ \case+      [TextLike s] -> do+        pure $ parseJson $ encodeUtf8 s & LBS.fromStrict++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "yaml:stdin" $ const do+      parseYaml <$> liftIO (LBS.hGetContents stdin)++    entry $ bindMatch "yaml:file" $ \case+      [StringLike fn] -> do+        parseYaml <$>  liftIO (LBS.readFile fn)++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "ini:stdin" $ const do+      parseIni <$> liftIO (LBS.hGetContents stdin)++    entry $ bindMatch "ini:file" $ \case+      [StringLike fn] -> do+        parseIni <$>  liftIO (LBS.readFile fn)++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "top:stdin" $ const do+      liftIO TIO.getContents+          <&> either (const nil) (mkList . fmap fixContext) . parseTop+++    entry $ bindMatch "top:string" $ \case+      [TextLike s] -> do+        pure $ either (const nil) (mkList . fmap fixContext) (parseTop s)++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "top:file" $ \case+      [StringLike fn] -> do+        liftIO $ TIO.readFile fn+            <&> either (const nil) (mkList . fmap fixContext) . parseTop++      _ -> throwIO (BadFormException @c nil)++    let dropShebang = id++    -- skips shebang+    entry $ bindMatch "top:file:run" $ nil_ $ \case+      a@(StringLike fn : args) -> do+        bindCliArgs a++        liftIO (TIO.readFile fn)+            <&> either (error.show) (fmap (fixContext @C @c) . dropShebang ) . parseTop+            <&> \case+              (ListVal (SymbolVal "#!" : _) : rest) -> rest+              rest -> rest+            >>= evalTop++      _ -> throwIO (BadFormException @c nil)+++    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 $  doParseTop w id s++        [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)++    let atomFrom = \case+          [StringLike s] -> pure (mkSym s)+          [e]            -> pure (mkSym $ show $ pretty e)+          es             -> atomFrom [concatTerms hcat es]++    brief "type of argument"+      $ args [arg "term" "term"]+      $ returns "symbol" "type"+      $ entry $ bindMatch "type" \case+        [ListVal _]    -> pure $ mkSym "list"+        [SymbolVal _]  -> pure $ mkSym "symbol"+        [LitStrVal _]  -> pure $ mkSym "string"+        [LitIntVal _]  -> pure $ mkSym "int"+        [LitScientificVal _] -> pure $ mkSym "real"+        [LitBoolVal _] -> pure $ mkSym "bool"+        _ -> throwIO (BadFormException @c nil)++    brief "creates a symbol from argument"+      $ args [arg "any-term" "term"]+      $ returns "symbol" ""+      do+        entry $ bindMatch "sym"  atomFrom+        entry $ bindMatch "atom" atomFrom+++    entry $ bindMatch "int" $ \case+      [ StringLike x ] -> pure $ maybe nil mkInt (readMay x)+      [ LitScientificVal v ] -> pure $ mkInt (round v)+      _ -> pure nil++    entry $ bindMatch "str" $ \case+      []  -> pure $ mkStr ""+      [x] -> pure $ mkStr (show $ pretty x)+      xs  -> pure $ mkStr $ mconcat [ show (pretty e) | e <- xs ]++    entry $ bindMatch "and" $ \case+      xs -> pure $ mkBool $ and [ not (isFalse x) | x <- xs ]++    entry $ bindMatch "or" $ \case+      xs -> pure $ mkBool $ or [ not (isFalse x) | x <- xs ]++    entry $ bindMatch "bf6:is" $ \case+      [a,b] | a == b -> pure a+      _ -> pure nil++    brief "compares two terms" $+      args [arg "term" "a", arg "term" "b"] $+      returns "boolean" "#t if terms are equal, otherwise #f" $+        entry $ bindMatch "eq?" $ \case+          [a, b] -> do+            pure $ if a == b then mkBool True else mkBool False+          _ -> throwIO (BadFormException @c nil)++    for_ ["int?", "sym?","bool?","str?","real?","is"] $ \pred -> do+      let ref = "bf6:" <> pred++      entry $ bindMatch pred $ \case+        [a]   -> do+          -- error $ show $ "FUCK!" <+> pretty a+          pure $ mkForm "builtin:closure" [mkSym ref,  a]++        e -> throwIO (BadFormException @c (mkList e))++      entry $ bindMatch ref $ \case+        [SymbolVal "_", b] ->do+          if bf6TypeOfPred pred == bf6TypeOf b then pure  b else pure nil++        [a@(SymbolVal e), b] -> do+          if a == b then pure  b else pure nil++        [a@(Literal _ _), b] -> do+          if bf6TypeOfPred pred == bf6TypeOf b && a == b then pure b else pure nil++        [a,b] -> do+          apply_ a [b] >>= \w -> do+            if isFalse w then pure nil else pure b++        e -> throwIO (BadFormException @c (mkList e))++    entry $ bindMatch "matched?" matched++    entry $ bindMatch "le?" $ \case+      [a, b] -> pure $ mkBool (compareSyn a b == LT)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "gt?" $ \case+      [a, b] -> pure $ mkBool (compareSyn a b == GT)+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "leq?" $ \case+      [a, b] -> pure $ mkBool (compareSyn a b /= GT)  -- LT или EQ+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "gte?" $ \case+      [a, b] -> pure $ mkBool (compareSyn a b /= LT)  -- GT или EQ+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "length" $ \case+      [ListVal es] -> pure $ mkInt (length es)+      [StringLike es] -> pure $ mkInt (length es)+      _ -> pure $ mkInt 0++    entry $ bindMatch "nil?" $ \case+      [ListVal []] -> pure $ mkBool True+      _ -> pure $ mkBool False++    entry $ bindMatch "not" $ \case+      [w] -> pure (mkBool (isFalse w))+      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "setenv" $ nil_ \case+      [ StringLike k, StringLike v] -> liftIO $ setEnv k v+      _ -> throwIO (BadFormException @c nil)++    brief "get system environment"+     $ args []+     $ args [ arg "string" "string" ]+     $ returns "env" "single var or dict of all vars"+     $ examples [qc|+      (env HOME)+      /home/user++      (env)+      (dict+         (HOME "/home/user") ... (CC "gcc") ...)+     |]+     $ entry $ bindMatch "env" $ \case+         [] -> do+           s <- liftIO getEnvironment+           pure $  mkList [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]++         [StringLike s] -> do+           liftIO (lookupEnv s)+              <&> maybe nil mkStr+         _ -> throwIO (BadFormException @c nil)++    -- FIXME: we-need-opaque-type+    entry $ bindMatch "blob:read-stdin" $ \case+      [] -> do+        blob <- liftIO BS8.getContents <&> BS8.unpack+        pure (mkForm "blob" [mkStr @c blob])++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "blob:read-file" $ \case+      [StringLike fn] -> do+        blob <- liftIO (BS8.readFile fn) <&> BS8.unpack+        pure (mkForm "blob" [mkStr @c blob])++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "blob:save" $ nil_ $ \case+      [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do+        let s = Text.unpack t & BS8.pack+        liftIO $ BS8.writeFile fn s++      _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "blob:put" $ nil_ $ \case+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do+        let s = Text.unpack t & BS8.pack+        liftIO $ BS8.putStr s++      _ -> 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 file"+     $ desc "bytes:strict:file FILE"+     $ entry $ bindMatch "bytes:strict:file" $ \case+        [ StringLike fn ] -> do+          liftIO (BS.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)++    brief "calls external process"+      $ entry $ bindMatch "call:proc" \case+          [StringLike what] -> lift do+            callProc what mempty mempty <&> mkList @c . fmap (fixContext)++          (StringLike x:xs) -> lift do+            callProc x (fmap (show.pretty) xs) mempty <&> mkList @c . fmap (fixContext)++          _ -> throwIO (BadFormException @c nil)+++    brief "calls external process"+      $ entry $ bindMatch "call:proc:raw" \case+          [StringLike what] -> lift do+            callProcRaw what mempty <&> mkStr @c++          (StringLike x:xs) -> lift do+            callProcRaw x (fmap (show.pretty) xs) <&> mkStr @c++          _ -> throwIO (BadFormException @c nil)+++    brief "call external process as pipe"+      $ entry $ bindMatch "proc:pipe" \case++          [StringLike name, ListVal (StringLikeList params), TextLike input ] -> lift do+            mkStr @c <$> pipeProcText name params input++          _ -> throwIO (BadFormException @c nil)++    entry $ bindMatch "sleep" $ nil_ $ \case+      [ LitIntVal n ] -> lift $ threadDelay ( fromIntegral n  * 1000000 )+      [ LitScientificVal n ] -> lift $ threadDelay ( round $ realToFrac n  * 1000000 )+      e -> throwIO (BadFormException @c (mkList e))++    brief "call external process as pipe"+      $ entry $ bindMatch "run:proc:attached" $ \syn -> do+           (cmd, args) <- case syn of+             [ StringLike name, ListVal (StringLikeList params) ] -> pure (name, params)+             StringLikeList (name:params) -> pure (name, params)+             e -> throwIO (BadFormException @c (mkList e))+           runProcAttached cmd args >>= \case+              Exit.ExitSuccess -> pure $ mkInt 0+              Exit.ExitFailure n -> pure $ mkInt n++    brief "call external process as pipe"+      $ entry $ bindMatch "run:proc:quiet" $ \syn -> do+           (cmd, args) <- case syn of+             [ StringLike name, ListVal (StringLikeList params) ] -> pure (name, params)+             StringLikeList (name:params) -> pure (name, params)+             e -> throwIO (BadFormException @c (mkList e))+           runProcQuiet cmd args >>= \case+              Exit.ExitSuccess -> pure $ mkInt 0+              Exit.ExitFailure n -> pure $ mkInt n++    entry $ bindMatch "fallback" $ \case+      [ e, expr ] -> do+        try @_ @SomeException (eval expr) >>= \case+          Right x -> pure x+          Left  _  -> eval e+      other -> throwIO (BadFormException @c (mkList other))++    entry $ bindMatch "grep" \case+      [TextLike needle, what ] | matchOne needle what+        -> pure what++      [TextLike needle, e@(ListVal xs) ] | any (matchOne needle) xs ->+        pure $ mkList (filter (matchOne needle) xs)++      _ ->  pure nil++    entry $ bindMatch "pwd" $ const $ do+      pwd <&> mkSym @c++    entry $ bindMatch "cd" $ nil_ $ \case+      [ StringLike dir ] -> cd dir+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "mkdir" $ nil_ $ \case+      [ ListVal (StringLikeList p) ] -> do+        forM_ p mkdir++      (StringLikeList p) -> forM_ p mkdir++      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "quit" $ nil_ $ \case+      [] -> liftIO $ Exit.exitSuccess+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "die" $ nil_ $ \case+      [] -> liftIO $ Exit.exitFailure+      e  -> liftIO $ Exit.die (show $ foldMap asSym e)++    entry $ bindMatch "cp" $ nil_ $ \case+      (StringLikeList p) -> liftIO do+        case List.uncons (reverse p) of+          Nothing -> pure ()+          Just (dest, rest) -> do+            forM_ (reverse rest) $ \f -> Dir.copyFileWithMetadata f dest++      e ->  throwIO $ BadFormException @c (mkList e)++    entry $ bindMatch "rm" $ nil_ $ \case+      (StringLikeList p) -> forM_ p rm+      [ ListVal (StringLikeList p) ] -> forM_ p rm+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "mv" $ nil_ $ \case+      [ StringLike a, StringLike b ] -> mv a b+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "touch" $ nil_ $ \case+      [ StringLike p ] -> touch p+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "sys:temp:dir:get" $ const do+      mkStr @c <$> sysTempDir++    entry $ bindMatch "sys:temp:file" $ \case+      [] -> mkSym @c <$> liftIO (Temp.emptySystemTempFile "bf6")+      [ StringLike d ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d "bf6")+      [ StringLike d, StringLike p ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d p)+      e -> throwIO $ BadFormException @c (mkList e)++    entry $ bindMatch "sys:temp:dir" $ \case+      [ ] -> do+        s <- sysTempDir+        mkSym @c <$> liftIO (Temp.createTempDirectory s "bf6")++      [ StringLike d ] -> do+        mkSym @c <$> liftIO (Temp.createTempDirectory d "bf6")++      [ StringLike d, StringLike p ] -> do+        mkSym @c <$> liftIO (Temp.createTempDirectory d p)++      e -> throwIO $ BadFormException @c (mkList e)++    entry $ bindMatch "uuid" $ const do+      mkSym @c . show <$> liftIO UUID.nextRandom++    brief "splits command line arguments"+      $ args [ arg "definintion" "list", arg "..." "CLI" ]+      $ desc ""+      $ entry $ bindMatch "cli:split" $ \case++        [ListVal p] -> pure nil+        [ListVal p,  ListVal es0] -> do++          opts <- Map.fromList <$> S.toList_ do+             for_ p $ \case+               StringLike x ->+                 S.yield (x, (0, mkSym x))++               ListVal [StringLike x, LitIntVal n] ->+                 S.yield (x, (n, mkSym @c x))++               ListVal [StringLike x, LitIntVal n, StringLike alias] ->+                 S.yield (x, (n, mkSym @c alias))++               _ -> pure ()++          -- error $ show opts++          parsed <- S.toList_ $ flip fix es0 $ \go -> \case+            [] -> pure ()++            ( w@(StringLike piece) : rest ) -> do+              case Map.lookup piece opts of+                Nothing     -> S.yield (Right w) >> go rest+                Just (0,s)  -> S.yield (Left (mkList [s, mkBool True])) >> go rest+                Just (1,s)  -> S.yield (Left (mkList [s, headDef nil rest])) >> go (drop 1 rest)+                Just (n',s) -> do+                  let n = fromIntegral n'+                  S.yield (Left (mkList [s, mkList (take n rest)]))+                  go (drop n rest)++            ( w : rest ) -> do+              S.yield (Right w) >> go (drop 1 rest)++          pure $  mkList [ mkList (lefts parsed)+                         , mkList (rights parsed)+                         ]++        _ -> pure nil++    entry $ bindMatch "path:join" $ \case+      StringLikeList es -> lift do+        pure $ mkSym (joinPath es)++      [ ListVal (StringLikeList es) ] -> do+        pure $ mkSym (joinPath es)++      _ -> pure nil++    brief "get file size"+     $ args [ arg "list" "filename" ]+     $ returns "file-size" "double"+     $  entry $ bindMatch "file:size" $ \case+          [ StringLike p ] -> mkInt <$> fileSize p+          _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:split" $ \case+      [ StringLike p ] -> pure $ mkList (fmap mkStr (splitPath p))+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:exists?" $ \case+      [ StringLike p ] -> lift do+        liftIO (Dir.doesPathExist p) <&> mkBool+      _ -> pure $ mkBool False++    entry $ bindMatch "path:dir?" $ \case+      [ StringLike p ] -> lift do+        liftIO (Dir.doesDirectoryExist p) <&> mkBool+      _ -> pure $ mkBool False++    entry $ bindMatch "path:file?" $ \case+      [ StringLike p ] -> lift do+        liftIO (Dir.doesFileExist p) <&> mkBool+      _ -> pure $ mkBool False++    entry $ bindMatch "path:ext" $ \case+      [ StringLike p ] -> pure $ mkSym (P.takeExtension p)+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:base" $ \case+      [ StringLike p ] -> pure $ mkSym (P.takeBaseName p)+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:filename" $ \case+      [ StringLike p ] -> pure $ mkSym (P.takeFileName p)+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:dirname" $ \case+      [ StringLike p ] -> pure $ mkSym (P.takeDirectory p)+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "path:expand" $ \case+      [ StringLike p ] -> lift do+        mkSym <$> canonicalizePath p+      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "dir:list:files" $ \case++      [ StringLike p, StringLike pat ] -> lift do+        dirFiles p <&> mkList . fmap mkSym . filter ( (pat ?==) . takeFileName )++      [ StringLike p ] -> lift do+        dirFiles p <&> mkList . fmap mkSym++      [] ->  dirFiles "." <&> mkList . fmap mkSym++      e -> throwIO $ BadFormException @c (mkList e)++    entry $ bindMatch "dir:list:all" $ \case+      [ StringLike p ] -> lift do+        what <- S.toList_ $ dirEntries p $ \e -> do+          let r = case e of+                   EntryFile   what -> mkList @c [mkSym what, mkSym "file" ]+                   EntryDir    what -> mkList @c [mkSym what, mkSym "dir"  ]+                   EntryOther  what -> mkList @c [mkSym what, mkSym "other" ]+          S.yield r+          pure True+        pure $ mkList what++      _ -> throwIO $ BadFormException @c nil++    entry $ bindMatch "random:flip" $ const do+      mkBool <$> randomIO @Bool++    entry $ bindMatch "random:int" $ \case+      [ ]  -> mkInt <$> randomIO+      [ LitIntVal a, LitIntVal b ]  -> mkInt <$> randomRIO (a,b)+      _ -> mkInt <$> randomIO++    entry $ bindMatch "random:uint" $ \case+      [ ] -> mkInt . abs <$> randomIO+      [ LitIntVal a, LitIntVal b ] -> mkInt <$> randomRIO (abs a, abs b)+      _ -> mkInt . abs <$> randomIO++    entry $ bindMatch "random:float" $ \input -> do+      case input of+        [] -> mkDouble <$> randomIO++        [ LitScientificVal a, LitScientificVal b ] -> do+          x <- randomRIO (realToFrac a, realToFrac b)+          pure $ mkDouble x++        _ -> mkDouble <$> randomIO+++    brief "average of numeric list"+      $ args [ arg "list" "list" ]+      $ returns "double" "double"+      $ entry $ bindMatch "stat:avg" \case+         [ ListVal es ] -> pure $ safeAvg es+         es             -> pure $ safeAvg es++    entry $ bindAlias "avg" "stat:avg"++    brief "median of numeric list"+      $ args [ arg "list" "list" ]+      $ returns "double" "double"+      $ entry $ bindMatch "stat:median" \case+         [ ListVal es ] -> pure $ safeMedian es+         es             -> pure $ safeMedian es++    entry $ bindAlias "median" "stat:median"++    entry $ bindMatch "random:shuffle" $ \input -> do+      case arglistOrList input of+        [] -> pure $ mkList []+        xs -> mkList <$> liftIO (shuffleM xs)++    entry $ bindMatch "random:seq" $ \input -> do+      case input of+        (LitIntVal n : rest) | n > 0 -> do+          case arglistOrList rest of+            [] -> pure $ mkList []+            xs -> do+              shuffled <- liftIO (shuffleM xs)+              pure . mkList $ take (fromIntegral n) shuffled++        _ -> pure $ mkList []++    entry $ bindMatch "random:choice" $ \input -> do+      case arglistOrList input of+        [] -> pure $ mkList []+        xs -> do+          i <- randomRIO (0, length xs - 1)+          case Safe.atMay xs i of+            Just v  -> pure v+            Nothing -> pure $ mkList []++    entry $ bindMatch "strftime" $ \case+      [ StringLike fmt, LitIntVal t ] -> do+        let utcTime = posixSecondsToUTCTime (fromIntegral t)+            formattedTime = formatTime defaultTimeLocale fmt utcTime+        pure $ mkStr formattedTime++      _ -> pure $ mkStr  ""++    entry $ bindMatch "forked" $ \case+      [ e ] -> do+        env <- ask+        po <- pwd+        oe <- liftIO $ getEnvironment+        lift do+          flip runContT pure do++            a <- ContT $ withAsyncBound $ do+                    runEval env [e]++            r <- wait a++            cd po+            restoreEnvironment oe+            pure r++      _ -> throwIO $ BadFormException @c nil+++    entry $ bindMatch "css" $ \case+        [ sel, ListVal kwa ] -> do++          let se = case sel of+                     ListVal es -> asSym $ concatTerms hcat $ List.intersperse (mkSym ",") es+                     TextLike s -> pretty $ mkSym @c s+                     other      -> pretty $ mkSym @c (show $ pretty other)++          let body = hsep+                       [ pretty k <> ":" <+> pretty v <> semi+                       | ListVal [TextLike k, v] <- kwa+                       ]++          let css = se <+> braces body++          pure $ mkStr (show css)++        _ -> pure nil++    entry $ bindMatch "html" $ \syn -> do++      let what = case syn of+            (TextLike tag : ListVal a : [ListVal content] )  -> Just (tag,a,content)+            (TextLike tag : ListVal a : content )  -> Just (tag,a,content)+            [TextLike tag] -> Just (tag,mempty,mempty)+            _ -> Nothing++      case what of++        Nothing -> pure nil++        Just (tag, a, content) -> do++          let attrs = [ Text.pack (show $ " " <> pretty k <> "=" <> dquotes (pretty (Html.text v)))+                      | ListVal [TextLike k, TextLike v] <- a+                      ] & mconcat++          let body = case concatTerms hsep (flattenList (mkList content)) of+                       TextLike s -> s+                       _          -> mempty++          let closing = if null content then mempty else angles ( "/" <> pretty tag )+          let wtf = angles (pretty tag <> pretty attrs) <> pretty body <> closing++          pure $ mkStr (show wtf)++++safeAvg :: forall c . IsContext c => [Syntax c] -> Syntax c+safeAvg [] = mkDouble 0.0+safeAvg es = mkDouble $ sum (map asDouble es) / fromIntegral (List.length es)++safeMedian :: forall c . IsContext c => [Syntax c] -> Syntax c+safeMedian []  = mkDouble 0.0+safeMedian esSorted  =+  let sorted = List.sort (map asDouble esSorted)+      n = length sorted+  in mkDouble $+     if odd n+        then sorted !! (n `div` 2)+        else let i = n `div` 2+              in (sorted !! (i - 1) + sorted !! i) / 2++asDouble :: forall c . IsContext c => Syntax c -> Double+asDouble = \case+  LitIntVal n        -> realToFrac n+  LitScientificVal n -> realToFrac n+  _                  -> 0.0++arglistOrList :: forall c . IsContext c => [Syntax c] -> [Syntax c]+arglistOrList = \case+  [ ListVal xs ] -> xs+  xs@(_:_)    -> xs+  _           -> []++parseJson :: forall c . IsContext c => LBS.ByteString -> Syntax c+parseJson input = case Aeson.decode @Value input of+    Just val -> mkSyntax @c val+    Nothing  -> nil++parseYaml :: forall c . IsContext c => LBS.ByteString -> Syntax c+parseYaml input =+  case Yaml.decodeEither' @Value (LBS.toStrict input) of+    Left _  -> nil @c+    Right val -> mkSyntax @c val++parseIni :: forall c . IsContext c => LBS.ByteString -> Syntax c+parseIni input =+  case Ini.parseIni (decodeUtf8With ignore $ LBS.toStrict  input) of+    Left _    -> nil+    Right ini -> mkSyntax @c (IniConfig ini)++matchOne :: IsContext c => Text -> Syntax c -> Bool+matchOne what = \case+  s@(TextLike x) | Text.isInfixOf what x -> True+  e@(ListVal xs) -> or [ Text.isInfixOf what s | TextLike s <- xs ]+  _ -> False++flattenList :: IsContext c => Syntax c -> [Syntax c]+flattenList (ListVal xs) = concatMap flattenList xs+flattenList x = [x]++partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM _ [] = pure ([], [])+partitionM p (x:xs) = do+  (yes, no) <- partitionM p xs+  b <- p x+  pure $ if b then (x:yes, no) else (yes, x:no)++groupByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [[a]]+groupByM _ [] = pure []+groupByM eq (x:xs) = do+  (same, rest) <- partitionM (eq x) xs+  groups <- groupByM eq rest+  pure ((x:same) : groups)++toOrdering :: Bool -> Ordering+toOrdering True  = LT+toOrdering False = GT++sortByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]+sortByM cmp xs = do+  let indexed = zip xs [0..]++  keyVals <- mapM (\(a, i) -> do+                      k <- mapM (\b -> cmp a b) xs+                      pure (sum (map fromEnum k), i, a))+                  indexed++  let sorted = List.sortOn (\(key, idx, _) -> (key, idx)) keyVals++  pure $ map (\(_, _, val) -> val) sorted++compareSyn :: Syntax c -> Syntax c -> Ordering+compareSyn (LitIntVal a) (LitIntVal b) = compare a b+compareSyn (LitScientificVal a) (LitScientificVal b) = compare a b+compareSyn (LitIntVal a) (LitScientificVal b) = compare (fromIntegral a) b+compareSyn (LitScientificVal a) (LitIntVal b) = compare a (fromIntegral b)+compareSyn (TextLike a) (TextLike b) = compare a b+compareSyn (ListVal a) (ListVal b) = compareLists a b+compareSyn _ _ = error "type check error"++compareLists :: [Syntax c] -> [Syntax c] -> Ordering+compareLists [] [] = EQ+compareLists [] _  = LT+compareLists _  [] = GT+compareLists (x:xs) (y:ys) =+  case compareSyn x y of+    EQ -> compareLists xs ys+    ord -> ord++concatTerms :: forall ann c . IsContext c => ( [Doc ann] -> Doc ann) ->  [Syntax c] -> Syntax c+concatTerms s =  \case+  [ListVal xs] -> do+     mkStr @c  ( show $ pretty $ concatTerms s xs )++  xs -> mkStr ( show $ s (fmap fmt xs) )+++matched :: forall c m . ( IsContext c+                        , MonadUnliftIO m+                        , Exception (BadFormException c)+                        )+       => [Syntax c] -> RunM c m (Syntax c)+matched = \case+  [ a, b ] -> do++    syn <- apply_ a [b]++    -- display_ $ show $ "AAAAA" <+> pretty a <+> pretty syn++    (_,w) <- runWriterT $ scan syn++    pure $ mkList [ mkList [mkSym n, e] | (n,e) <- w ]++    where+      scan = \case+        ListVal [SymbolVal x, e] -> do+          -- display_ $ "KHUYAK" <+> pretty x <+> pretty e+          -- e' <- scan e+          tell [(x, e)]+          pure e++        ListVal es -> do+          es' <- mapM scan es+          pure (mkList es')++        e -> do+          tell [("_", e)]+          pure e++  z -> throwIO (BadFormException @c (mkList z))++bf6TypeOf :: forall c . (IsContext c)+          => Syntax c+          -> Maybe (Syntax c)+bf6TypeOf = \case+  ListVal{}   -> pure $ mkSym "list"+  SymbolVal{}  -> pure $ mkSym "symbol"+  LitStrVal{}   -> pure $ mkSym "string"+  LitIntVal{}   -> pure $ mkSym "int"+  LitScientificVal{} -> pure $ mkSym "real"+  LitBoolVal{} -> pure $ mkSym "bool"+  OpaqueValue{} -> pure $ mkSym "opaque"+  _ -> Nothing+++bf6TypeOfPred :: forall c . (IsContext c)+          => Id+          -> Maybe (Syntax c)+bf6TypeOfPred = \case+  "list?"   -> pure $ mkSym "list"+  "sym?"    -> pure $ mkSym "symbol"+  "str?"    -> pure $ mkSym "string"+  "int?"    -> pure $ mkSym "int"+  "real?"   -> pure $ mkSym "real"+  "bool?"   -> pure $ mkSym "bool"+  _ -> Nothing++asSym :: forall ann c . IsContext c => Syntax c -> Doc ann+asSym = \case+  TextLike s -> pretty (mkSym @c s)+  other      -> pretty other++restoreEnvironment :: MonadIO  m => [(String, String)] -> m ()+restoreEnvironment newEnv = liftIO do+    currentEnv <- getEnvironment+    let toRemove = map fst currentEnv \\ map fst newEnv+    mapM_ unsetEnv toRemove+    mapM_ (uncurry setEnv) newEnv+++substIn :: forall c . IsContext c => HashMap Id (Syntax c) -> Syntax c -> Syntax c+substIn repl = go+  where+    go = \case+      List    c xs -> List c (fmap go xs)+      s@(Symbol _ n)  -> fromMaybe s (HM.lookup n repl)+      e    -> e++matchPattern :: forall c m . (IsContext c, MonadUnliftIO m, Exception (BadFormException c))+             => Syntax c -- ^ pattern+             -> Syntax c -- ^ expression+             -> Syntax c -- ^ production+             -> RunM c m (Maybe (Syntax c))+matchPattern p0 e0 syn = do++  pMatchOne p0 e0 >>= \case+    Nothing   -> pure $ Nothing+    Just repl -> do++      d0 <- ask >>= readTVarIO++      for_ (List.reverse repl) $ \(n,e) -> do+        bind n e++      r <- eval syn++      t <- ask+      atomically (writeTVar t d0)++      pure $ Just r++  where++    pMatchOne p e = do++      case p of++        ListVal [ SymbolVal "?", SymbolVal n, pe ] -> do+          pMatchOne pe e >>= \case+            Just found -> pure $ Just $ (n,e) : found+            Nothing -> pure Nothing++        ListVal [ SymbolVal "list?" ] | isNil e -> pure $ Just []++        ListVal (SymbolVal "list?" : rest) -> runMaybeT do++          lls <- case e of+                   ListVal es -> pure es+                   _          -> mzero++          flip fix (rest,lls,mempty) \next -> \case++            ([SymbolVal "..."], xs, rs) -> pure (("...", mkList xs) : rs)++            ([SymbolVal ".", SymbolVal b], xs, rs) -> do+              pure ((b, mkList xs) : rs)++            (SymbolVal "..." : _ : _ , _, _) -> throwIO $ BadFormException p++            (SymbolVal "."   : _, _, _) -> throwIO $ BadFormException p++            (SymbolVal c : es, x:xs, rs) -> do+              next (es,xs,(c,x):rs)++            ( pp : ps, x:xs, rs) -> do+              r <- MaybeT (pMatchOne pp x)+              next (ps, xs, r <> rs)++            ([],[],rs) -> pure rs++            (what, _, _) -> mzero++        ListVal [ SymbolVal pp, SymbolVal "_"] -> do+          if bf6TypeOf e == bf6TypeOfPred pp then pure $ Just [] else pure Nothing++        ListVal [ SymbolVal pp ] | isJust (bf6TypeOfPred @c pp) -> do+          if bf6TypeOf e == bf6TypeOfPred pp then pure $ Just [] else pure Nothing++        ListVal [ SymbolVal pp, ppe@(ListVal{}) ] -> do+          let tp = bf6TypeOf e == bf6TypeOfPred pp+          if not tp then+            pure Nothing+          else do+            pe <- eval ppe+            what <- apply_ @c pe [e]+            if isTrue what then pure $ Just [] else pure Nothing++        ListVal [ SymbolVal pp, pEq' ] -> do+         if bf6TypeOf e == bf6TypeOfPred pp then do+           pEq <- eval pEq'+           if pEq == e then pure $ Just [] else pure Nothing+         else+           pure Nothing++        SymbolVal n -> pure $ Just [(n,e)]++        zu -> error $ show $ "not yet" <+> pretty zu++
+ lib/Data/Config/Suckless/Syntax.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# 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(..)+  , nil+  , mkList+  , mkBool+  , synToText+  , MkId(..)+  , MkForm(..)+  , MkSym(..)+  , MkInt(..)+  , MkStr(..)+  , MkDouble(..)+  , MkSyntax(..)+  , pattern SymbolVal+  , pattern ListVal+  , pattern LitIntVal+  , pattern LitStrVal+  , pattern LitBoolVal+  , pattern LitScientificVal+  , pattern StringLike+  , pattern TextLike+  , pattern StringLikeList+  , pattern TextLikeList+  , pattern IntLikeList+  , pattern Nil+  , pattern OpaqueVal+  , pattern MatchOpaqueVal+  )+  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 Data.Aeson+import Data.Aeson.Key as Aeson+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++pattern SymbolVal :: Id -> Syntax c+pattern SymbolVal v <- Symbol _ v++-- pattern LitVal :: forall {c}. Id -> Li+pattern LitIntVal :: Integer -> Syntax c+pattern LitIntVal v <- Literal _ (LitInt v)++pattern LitScientificVal :: Scientific -> Syntax c+pattern LitScientificVal v <- Literal _ (LitScientific v)++pattern LitStrVal :: Text -> Syntax c+pattern LitStrVal v <- Literal _ (LitStr v)++pattern LitBoolVal :: Bool -> Syntax c+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++intLike :: Syntax c -> Maybe Integer+intLike = \case+  LitIntVal s -> Just s+  _ -> Nothing++stringLikeList :: [Syntax c] -> [String]+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes+++intLikeList :: [Syntax c] -> [Integer]+intLikeList syn = [ intLike s | s <- syn ] & takeWhile isJust & catMaybes++textLikeList :: [Syntax c] -> [Text]+textLikeList syn = [ textLike 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)+++pattern TextLikeList :: forall {c} . [Text] -> [Syntax c]+pattern TextLikeList e <- (textLikeList -> e)++pattern IntLikeList :: forall {c} . [Integer] -> [Syntax c]+pattern IntLikeList e <- (intLikeList -> e)++pattern Nil :: forall {c} . Syntax c+pattern Nil <- ListVal []++pattern OpaqueVal :: forall {c} . Opaque -> Syntax c+pattern OpaqueVal box <- OpaqueValue box++-- by @qnikst, thanks, dude+pattern MatchOpaqueVal :: forall c a . (IsContext c, Typeable a) => a -> Syntax c+pattern MatchOpaqueVal o <- (OpaqueVal (fromOpaque -> Just o))++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++data instance Context () = EmptyContext++instance IsContext () where+  noContext = EmptyContext++class HasContext c a where++class IsLiteral a where+  mkLit :: a -> Literal++class IsContext c => ToSyntax c a where+  toSyntax :: a -> Syntax c++newtype Id =+  Id Text+  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+  | LitScientific Scientific+  | LitBool   Bool+  deriving stock (Eq,Ord,Data,Generic,Show)++instance IsLiteral Text where+  mkLit = LitStr++instance IsLiteral Bool where+  mkLit = LitBool++instance IsLiteral Integer where+  mkLit = LitInt++data C = C+         deriving stock (Eq,Ord,Show,Data,Typeable,Generic)++-- simple, yet sufficient context+--  Integer may be offset, maybe line number,+--  token number, whatever+--  it's up to parser to use this context for+--  error printing, etc+newtype instance (Context C) =+  SimpleContext { fromSimpleContext :: Maybe Integer }+  deriving stock (Eq,Ord,Show,Data,Typeable,Generic)++instance IsContext C where+  noContext = SimpleContext Nothing++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)++instance Pretty (Syntax c) where+  pretty (Literal _ ast) = pretty ast+  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+    LitStr s  -> dquotes (pretty s)+    LitInt i  -> pretty i+    LitScientific v  -> viaShow v++    LitBool b | b          -> "#t"+              | otherwise  -> "#f"+++instance ToJSON Literal where+    toJSON (LitStr s)       = String s+    toJSON (LitInt i)       = Number (fromInteger i)+    toJSON (LitScientific s) = Number s+    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+    toJSON (List _ items) =+        case items of+            (Symbol _ "object" : rest) ->+                object $ mapMaybe pairToKeyValue rest+            _ -> Array . V.fromList $ fmap toJSON items++      where+        pairToKeyValue :: Syntax c -> Maybe (Key, Value)+        pairToKeyValue (List _ [SymbolVal (Id k), SymbolVal ":", v]) = Just (fromText k .= toJSON v)+        pairToKeyValue (List _ [LitStrVal k, SymbolVal ":", v]) = Just (fromText k .= toJSON v)+        pairToKeyValue _ = Nothing+++instance IsContext c => FromJSON (Syntax c) where+    parseJSON (String t) = pure $ Literal noContext (LitStr t)+    parseJSON (Number n)+        | isInteger n = pure $ Literal noContext (LitInt (floor n))+        | otherwise   = pure $ Literal noContext (LitScientific n)+    parseJSON (Bool b)  = pure $ Literal noContext (LitBool b)+    parseJSON (Array a) = List noContext <$> mapM parseJSON (V.toList a)+    parseJSON (Object o) = do+        pairs <- forM (Aeson.toList o) $ \(key, value) -> do+            valueSyntax <- parseJSON value+            pure $ List noContext [ Symbol noContext (Id (toText key))+                                  , Symbol noContext ":"+                                  , valueSyntax+                                  ]+        pure $ List noContext (Symbol noContext (Id "object") : pairs)+    parseJSON _ = fail "Cannot parse JSON to Syntax"++class MkId a where+  mkId :: a -> Id++instance MkId Text where+  mkId = Id++instance MkId String where+  mkId  = Id . Text.pack++class IsContext c => MkSym c a where+  mkSym :: a -> Syntax c++instance IsContext c => MkSym c String where+  mkSym s = Symbol noContext (Id $ Text.pack s)++instance IsContext c => MkSym c Text where+  mkSym s = Symbol noContext (Id s)++instance MkId (Text,Int) where+  mkId (p, i) = Id (p <> Text.pack (show i))++instance MkId (String,Integer) where+  mkId (p, i) = Id (Text.pack (p  <> show i))++instance IsContext c => MkSym c Id where+  mkSym = Symbol noContext++instance {-# OVERLAPPABLE #-} (IsContext c, Pretty a) => MkSym c a where+  mkSym a = Symbol noContext (mkId (show $ pretty a))++class IsContext c => MkStr c s where+  mkStr :: s -> Syntax c++instance IsContext c => MkStr c String where+  mkStr s = Literal noContext $ LitStr (Text.pack s)++instance IsContext c => MkStr c Text where+  mkStr s = Literal noContext $ LitStr s++instance IsContext c => MkStr c [Text] where+  mkStr s = mkStr $ mconcat s++instance IsContext c => MkStr c [String] where+  mkStr s = mkStr $ mconcat s++instance IsContext c => MkStr c [Doc ann] where+  mkStr s = mkStr $ show (hsep s)++mkBool :: forall c . IsContext c => Bool -> Syntax c+mkBool v = Literal noContext (LitBool v)++nil :: forall c . IsContext c => Syntax c+nil = List noContext []++class IsContext c => MkForm c a where+ mkForm :: a-> [Syntax c] -> Syntax c++instance (IsContext c, MkSym c s) => MkForm c s where+ mkForm s sy = List noContext ( mkSym @c s :  sy )++mkList :: forall c. IsContext c => [Syntax c] -> Syntax c+mkList = List noContext++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)++class MkSyntax c a where+  mkSyntax :: a -> Syntax c++instance IsContext c => MkSyntax c (Syntax c) where+  mkSyntax = id++instance IsContext c => MkSyntax c Value where+  mkSyntax Null = nil+  mkSyntax (Number n) = mkDouble n+  mkSyntax (String n) = mkStr n+  mkSyntax (Bool b) = mkBool b+  mkSyntax (Array ns) = mkList [ mkSyntax n | n <- V.toList ns]+  mkSyntax (Object kv) = mkList [ mkList [mkSym (Aeson.toText k), mkSyntax v] | (k,v) <- Aeson.toList kv]++++synToText :: forall c . IsContext c => Syntax c -> Text+synToText = \case+  ListVal  xs        -> foldMap synToText xs+  TextLike  x        -> x+  LitIntVal x        -> Text.pack (show x)+  LitScientificVal x -> Text.pack (show x)+  LitBoolVal f       -> Text.pack (show (pretty f))+  OpaqueValue{}      -> Text.pack "#opaque"+{-# COMPLETE ListVal, TextLike, LitIntVal, LitScientificVal, LitBoolVal, OpaqueValue #-}++
+ lib/Data/Config/Suckless/System.hs view
@@ -0,0 +1,129 @@+{-# Language MultiWayIf #-}+module Data.Config.Suckless.System where++import Data.Function+import System.FilePath+import System.Directory qualified as D+import System.IO.Temp qualified as Temp+import Data.ByteString.Lazy qualified as LBS+import UnliftIO+import Control.Exception qualified as E+import Control.Monad++import Streaming.Prelude qualified as S++data MkDirOpt = MkDirOptNone++class HasMkDirOptions a where+  mkdirOpts :: a -> [MkDirOpt]++instance HasMkDirOptions FilePath where+  mkdirOpts = mempty++class ToFilePath a where+  toFilePath :: a -> FilePath++instance ToFilePath FilePath where+  toFilePath = id++mkdir :: (MonadIO m, ToFilePath a) => a -> m ()+mkdir a = do+  void $ liftIO $ E.try @SomeException (D.createDirectoryIfMissing True (toFilePath a))++data TouchOpt = TouchEasy | TouchHard+                 deriving stock (Eq,Ord,Show)++class ToFilePath a => HasTouchOpts a where+  touchOpts :: a -> [TouchOpt]++instance HasTouchOpts FilePath where+  touchOpts = const [TouchEasy]++touch :: (MonadIO m, HasTouchOpts a) => a -> m ()+touch what = do+  here <- doesPathExist fn+  dir  <- doesDirectoryExist fn++  when (not here || hard) do+    mkdir (takeDirectory fn)+    unless dir do+      liftIO $ LBS.appendFile fn mempty++  where+    hard = TouchHard `elem` touchOpts  what+    fn = toFilePath what++pwd :: MonadIO m => m FilePath+pwd = liftIO D.getCurrentDirectory+++doesPathExist :: MonadIO m => FilePath -> m Bool+doesPathExist = liftIO . D.doesPathExist++canonicalizePath :: MonadIO m => FilePath -> m FilePath+canonicalizePath = liftIO . D.canonicalizePath++expandPath :: MonadIO m => FilePath -> m FilePath+expandPath = liftIO . D.canonicalizePath++doesDirectoryExist :: MonadIO m => FilePath -> m Bool+doesDirectoryExist = liftIO . D.doesDirectoryExist++doesFileExist :: MonadIO m => FilePath -> m Bool+doesFileExist = liftIO . D.doesFileExist+++fileSize :: MonadIO m => FilePath -> m Integer+fileSize = liftIO . D.getFileSize++mv :: MonadIO m => FilePath -> FilePath -> m ()+mv a b = liftIO $ D.renamePath a b++rm :: MonadIO m => FilePath -> m ()+rm fn = liftIO $ D.removePathForcibly fn++home :: MonadIO m => m FilePath+home = liftIO D.getHomeDirectory++cd :: MonadIO m => FilePath -> m()+cd = liftIO . D.setCurrentDirectory++data DirEntry =+    EntryFile  { dirEntryPath :: FilePath }+  | EntryDir   { dirEntryPath :: FilePath }+  | EntryOther { dirEntryPath :: FilePath }++dirFiles :: MonadIO m => FilePath -> m [FilePath]+dirFiles d = S.toList_ $ do+  dirEntries d $ \case+    EntryFile f -> S.yield f >> pure True+    _ -> pure True++dirEntries :: MonadIO m => FilePath -> ( DirEntry -> m Bool ) -> m ()+dirEntries dir what  = do+  es <- liftIO $ D.listDirectory dir++  flip fix es $ \next -> \case+    [] -> pure ()+    (x:xs) -> do+      let entry = dir </> x+      isFile <- liftIO (D.doesFileExist entry)+      isDir <- liftIO (D.doesDirectoryExist entry)+      if | isFile    -> continueThen (what (EntryFile entry)) (next xs)+         | isDir     -> continueThen (what (EntryDir entry)) (next xs)+         | otherwise -> continueThen (what (EntryOther entry)) (next xs)++  where+    continueThen a b = do+      r <- a+      when r b++sysTempDir :: MonadIO m => m FilePath+sysTempDir = do+  tmp1 <- liftIO D.getTemporaryDirectory+  tmp2 <- liftIO $ Temp.getCanonicalTemporaryDirectory+  pure $ if null tmp1 then tmp2 else tmp1++++
+ lib/Data/Config/Suckless/Types.hs view
@@ -0,0 +1,1 @@+module Data.Config.Suckless.Types where
+ lib/Data/Text/Fuzzy/SExp.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.Text.Fuzzy.SExp where++import Data.Text (Text)++import Control.Applicative+import Control.Monad+import Data.Function+import Data.Functor+import Data.Text.Fuzzy.Tokenize+import Control.Monad.Reader+import Data.Typeable+import Control.Monad.Except+import Control.Exception+import Control.Monad.RWS+import Data.Maybe+import Data.Char (isSpace,digitToInt)+import Data.Generics.Uniplate.Data()+import Safe+import Data.Data+import GHC.Generics+import Lens.Micro.Platform+import Data.Text qualified as Text+import Data.Coerce+import Data.Scientific++import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict  qualified as HM++import Prettyprinter hiding (braces,list)+++import Streaming.Prelude qualified as S++data TTok = TChar Char+          | TSChar Char+          | TPunct Char+          | TText Text+          | TStrLit Text+          | TKeyword Text+          | TEmpty+          | TIndent Int+          deriving stock (Eq,Ord,Show,Data,Generic)++instance IsToken TTok where+  mkChar = TChar+  mkSChar = TSChar+  mkPunct = TPunct+  mkText = TText+  mkStrLit = TStrLit+  mkKeyword = TKeyword+  mkEmpty = TEmpty+  mkIndent = TIndent++newtype C0 = C0 (Maybe Int)+             deriving stock (Eq,Ord,Show,Data,Typeable,Generic)++data SExpParseError =+    ParensOver  C0+  | ParensUnder C0+  | ParensUnmatched C0+  | SyntaxError C0+  deriving stock (Show,Typeable)++instance Exception SExpParseError++data NumType =+    NumInteger Integer+  | NumDouble  Scientific+  deriving stock (Eq,Ord,Show,Data,Generic)++class Monoid c => ForMicroSexp c where++instance Monoid C0 where+  mempty = C0 Nothing++instance Semigroup C0 where+  (<>) (C0 a) (C0 b) = C0 (b <|> a)++instance ForMicroSexp C0 where+++instance ForMicroSexp () where++data MicroSexp c =+    List_    c [MicroSexp c]+  | Symbol_  c Text+  | String_  c Text+  | Number_  c NumType+  | Boolean_ c Bool+  deriving stock (Show,Data,Generic)++pattern List :: ForMicroSexp c => [MicroSexp c] -> MicroSexp c+pattern List xs <- List_ _ xs where+  List xs = List_ mempty xs++pattern Symbol :: ForMicroSexp c => Text -> MicroSexp c+pattern Symbol xs <- Symbol_ _ xs where+  Symbol xs = Symbol_ mempty xs++pattern String :: ForMicroSexp c => Text -> MicroSexp c+pattern String x <- String_ _ x where+  String x = String_ mempty x++pattern Number :: ForMicroSexp c => NumType -> MicroSexp c+pattern Number n <- Number_ _ n where+  Number n = Number_ mempty n++pattern Boolean :: ForMicroSexp c => Bool -> MicroSexp c+pattern Boolean b <- Boolean_ _ b where+  Boolean b = Boolean_ mempty b++{-# COMPLETE List, Symbol, String, Number, Boolean #-}+++contextOf :: Lens (MicroSexp c) (MicroSexp c) c c+contextOf = lens g s+  where+    s sexp c = case sexp of+      List_    _  a -> List_ c a+      Symbol_  _  a -> Symbol_ c a+      String_  _  a -> String_ c a+      Number_  _  a -> Number_ c a+      Boolean_ _  a -> Boolean_ c a++    g = \case+      List_ c    _ -> c+      Symbol_ c  _ -> c+      String_ c  _ -> c+      Number_ c  _ -> c+      Boolean_ c _ -> c++nil :: forall c . ForMicroSexp c => MicroSexp c+nil = List []++symbol :: forall c . ForMicroSexp c => Text -> MicroSexp c+symbol = Symbol++str :: forall c . ForMicroSexp c => Text -> MicroSexp c+str = String++newtype SExpEnv =+  SExpEnv+  { sexpTranslate :: Bool+  }++data SExpState =+  SExpState+  { _sexpLno    :: Int+  , _sexpBraces :: [Char]+  }++makeLenses 'SExpState++defEnv :: SExpEnv+defEnv = SExpEnv True++newtype SExpM m a = SExpM { fromSexpM :: RWST SExpEnv () SExpState m a }+                    deriving newtype+                      ( Applicative+                      , Functor+                      , Monad+                      , MonadState SExpState+                      , MonadReader SExpEnv+                      , MonadTrans+                      )+++instance MonadError SExpParseError m => MonadError SExpParseError (SExpM m) where+  throwError = lift . throwError+  catchError w  = catchError (coerce $ fromSexpM w)++tokenizeSexp :: Text -> [TTok]+tokenizeSexp txt =  do+  let spec = delims " \r\t" <> comment ";"+                            <> punct "@,`'{}()[]\n"+                            <> sqq+                            <> uw+                            <> esc+  tokenize spec txt++runSexpM :: Monad m => SExpM m a -> m a+runSexpM f = evalRWST (fromSexpM f) defEnv (SExpState 0 []) <&> fst+++parseSexp :: (ForMicroSexp c, MonadError SExpParseError m) => Text -> m (MicroSexp c)+parseSexp txt = do+  (s, _) <- runSexpM do+             (s,rest) <- sexp (tokenizeSexp txt)+             checkBraces+             pure (s,rest)++  pure s++checkBraces :: (MonadError SExpParseError m) => SExpM m ()+checkBraces = do+  braces <- gets (view sexpBraces)+  unless (null braces) $ raiseWith ParensUnder++succLno :: (MonadError SExpParseError m) => SExpM m ()+succLno = modify (over sexpLno succ)++parseTop :: (ForMicroSexp c, MonadError SExpParseError m) => Text -> m [MicroSexp c]+parseTop txt = do+  let tokens = tokenizeSexp txt+  S.toList_ $ runSexpM do+    flip fix (mempty,tokens) $ \next -> \case+      (acc, []) -> do+        emit acc+      (acc, TPunct '\n' : rest) -> do+        succLno+        emit acc+        next (mempty,rest)+      (acc, rest) -> do+        (s, xs) <- sexp rest+        next (acc <> [s],xs)++  where++    emit [] = pure ()+    emit wtf = case wtf of+      [List one] -> lift $ S.yield (List one)+      xs    -> lift $ S.yield (List xs)+++sexp :: forall c m . (ForMicroSexp c, MonadError SExpParseError m) => [TTok] -> SExpM m (MicroSexp c, [TTok])+sexp s = case s of+  [] -> do+    checkBraces+    pure (nil, mempty)++  (TText l : w) -> (,w) <$> trNum (Symbol l)++  (TStrLit l : w) -> pure (String l, w)++  (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 ',' : 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++  (TPunct c : rest) | isBrace c  ->+    maybe (pure (nil, rest)) (`list` rest) (closing c)+                    | otherwise -> do+                        raiseWith ParensOver++  ( _ : _ ) -> raiseWith SyntaxError++  where++    setContext w = do+      co <- getC0+      pure $ over _2 (set contextOf co) w++    isBrace :: Char -> Bool+    isBrace c = HM.member c braces++    closing :: Char -> Maybe Char+    closing c = HM.lookup c braces++    braces :: HashMap Char Char+    braces = HM.fromList[ ('{', '}')+                        , ('(', ')')+                        , ('[', ']')+                        , ('<', '>')+                        ]++    cBraces :: [Char]+    cBraces = HM.elems braces++    trNum tok = do++      trans <- asks sexpTranslate++      case tok of+        Symbol s | trans -> do+          let s0 = Text.unpack s++          let what = Number . NumInteger <$> readMay @Integer s0+                    <|>+                    Number . NumInteger <$> parseBinary s0+                    <|>+                    Number . NumDouble <$> readMay @Scientific s0+                    <|>+                    ( case  s of+                        "#t" -> Just (Boolean True)+                        "#f" -> Just (Boolean False)+                        _    -> Nothing+                    )++          pure $ fromMaybe (Symbol s) what+++        x        -> pure x+    {-# INLINE trNum #-}++    list :: (ForMicroSexp c, MonadError SExpParseError m)+         => Char+         -> [TTok]+         -> SExpM m (MicroSexp c, [TTok])++    list _ [] = raiseWith ParensUnder++    list cb tokens = do+      modify $ over sexpBraces (cb:)++      go cb mempty tokens++      where++        isClosingFor :: Char -> Bool+        isClosingFor c = c `elem` cBraces++        go _ _ [] = do+          checkBraces+          pure (List mempty, mempty)++        go cl acc (TPunct c : rest) | isSpace c = do+          go cl acc rest++        go cl acc (TPunct c : rest)+          | isClosingFor c && c == cl = do+              modify $ over sexpBraces (drop 1)+              pure (List (reverse acc), rest)++          | isClosingFor c && c /= cl = do+              raiseWith ParensUnmatched+              -- throwError =<< ParensUnmatched <$> undefined++        go cl acc rest = do+          (e,r) <- sexp rest+          go cl (e : acc) r+++getC0 :: Monad m => SExpM m C0+getC0 = do+  lno <- gets (view sexpLno)+  pure (C0 (Just lno))++raiseWith :: (MonadError SExpParseError m)+          => (C0 -> SExpParseError) -> SExpM m b++raiseWith a = throwError =<< a <$> getC0++instance Pretty NumType where+   pretty = \case+    NumInteger n -> pretty n+    NumDouble  n -> viaShow n++instance ForMicroSexp c => Pretty (MicroSexp c) where++  pretty = \case+    List xs   -> parens (hsep (fmap pretty xs))+    String s  -> dquotes (pretty s)+    Symbol s  -> pretty s+    Number n  -> pretty n+    Boolean True -> pretty  "#t"+    Boolean False -> pretty  "#f"++isBinaryDigit :: Char -> Bool+isBinaryDigit c = c == '0' || c == '1'++parseBinary :: String -> Maybe Integer+parseBinary str =+  let+      withoutPrefix = case str of+                        '0':'b':rest -> Just rest+                        '0':'B':rest -> Just rest+                        _            -> Nothing+  in if isJust withoutPrefix && all isBinaryDigit (fromJust withoutPrefix)+     then Just $ foldl (\acc x -> acc * 2 + toInteger (digitToInt x)) 0 (fromJust withoutPrefix)+     else Nothing+
+ lib/Data/Text/Fuzzy/Tokenize.hs view
@@ -0,0 +1,547 @@+-- |+-- Module      :  Data.Text.Fuzzy.Tokenize+-- Copyright   :  Dmitry Zuikov 2020+-- License     :  MIT+--+-- Maintainer  :  dzuikov@gmail.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- The lightweight and multi-functional text tokenizer allowing different types of text tokenization+-- depending on it's settings.+--+-- It may be used in different sutiations, for DSL, text markups or even for parsing simple grammars+-- easier and sometimes faster than in case of usage mainstream parsing combinators or parser+-- generators.+--+-- The primary goal of this package  is to parse unstructured text data, however it may be  used for+-- parsing  such data formats as CSV with ease.+--+-- Currently it supports the following types of entities: atoms, string literals (currently with the+-- minimal set of escaped characters), punctuation characters and delimeters.+--+-- == Examples+-- === Simple CSV-like tokenization+-- >>> tokenize (delims ":") "aaa : bebeb : qqq ::::" :: [Text]+-- ["aaa "," bebeb "," qqq "]+--+-- >>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Text]+-- ["aaa "," bebeb "," qqq ","","","",""]+--+-- >>>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Maybe Text]+-- [Just "aaa ",Just " bebeb ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]+--+-- >>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]+-- [Just "aaa ",Just " ",Just "bebeb:colon inside",Just " ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]+--+-- >>> let spec = sl<>delims ":"<>sq<>emptyFields<>noslits+-- >>> tokenize spec "   aaa :   'bebeb:colon inside' : qqq ::::" :: [Maybe Text]+-- [Just "aaa ",Just "bebeb:colon inside ",Just "qqq ",Nothing,Nothing,Nothing,Nothing]+--+-- >>> let spec = delims ":"<>sq<>emptyFields<>uw<>noslits+-- >>> tokenize spec "  a  b  c  : 'bebeb:colon inside' : qqq ::::"  :: [Maybe Text]+-- [Just "a b c",Just "bebeb:colon inside",Just "qqq",Nothing,Nothing,Nothing,Nothing]+--+-- == Notes+--+-- === About the delimeter tokens+-- This type of tokens appears during a "delimited"+-- formats processing and disappears in results. Currenly+-- you will never see it unless normalization is turned off by 'nn' option.+--+-- The delimeters make sense in case of processing the CSV-like formats,+-- but in this case you probably need only values in results.+--+-- This behavior may be changed later. But right now delimeters seem pointless+-- in results. If you process some sort of grammar where delimeter character+-- is important, you may use punctuation instead, i.e:+--+-- >>> let spec = delims " \t"<>punct ",;()" <>emptyFields<>sq+-- >>> tokenize spec "( delimeters , are , important, 'spaces are not');" :: [Text]+-- ["(","delimeters",",","are",",","important",",","spaces are not",")",";"]+--+-- == Other+-- For CSV-like formats it makes sense to split text to lines first,+-- otherwise newline characters may cause to weird results+--+--++module Data.Text.Fuzzy.Tokenize ( TokenizeSpec+                                , IsToken(..)+                                , tokenize+                                , esc+                                , addEmptyFields+                                , emptyFields+                                , nn+                                , sq+                                , sqq+                                , noslits+                                , sl+                                , sr+                                , uw+                                , delims+                                , comment+                                , punct+                                , indent+                                , itabstops+                                , keywords+                                , eol+                                ) where++import Prelude hiding (init)++import Control.Applicative+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Monoid()+import Data.Set (Set)+import Data.Text (Text)+import Data.Char qualified as Char+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text++import Control.Monad (when)+import Control.Monad.RWS++-- | Tokenization settings. Use mempty for an empty value+-- and construction functions for changing the settings.+--+data TokenizeSpec = TokenizeSpec { tsAtoms          :: Set Text+                                 , tsStringQQ       :: Maybe Bool+                                 , tsStringQ        :: Maybe Bool+                                 , tsNoSlits        :: Maybe Bool+                                 , tsLineComment    :: Map Char Text+                                 , tsDelims         :: Set Char+                                 , tsEol            :: Maybe Bool+                                 , tsStripLeft      :: Maybe Bool+                                 , tsStripRight     :: Maybe Bool+                                 , tsUW             :: Maybe Bool+                                 , tsNotNormalize   :: Maybe Bool+                                 , tsEsc            :: Maybe Bool+                                 , tsAddEmptyFields :: Maybe Bool+                                 , tsPunct          :: Set Char+                                 , tsIndent         :: Maybe Bool+                                 , tsItabStops      :: Maybe Int+                                 , tsKeywords       :: Set Text+                                 }+                    deriving (Eq,Ord,Show)+++instance Semigroup TokenizeSpec where+  (<>) a b = TokenizeSpec { tsAtoms       = tsAtoms b <> tsAtoms a+                          , tsStringQQ    = tsStringQQ b <|> tsStringQQ a+                          , tsStringQ     = tsStringQ b  <|> tsStringQ a+                          , tsNoSlits     = tsNoSlits b <|> tsNoSlits a+                          , tsLineComment = tsLineComment b <> tsLineComment a+                          , tsDelims      = tsDelims b <> tsDelims a+                          , tsEol         = tsEol b <|> tsEol a+                          , tsStripLeft   = tsStripLeft b <|> tsStripLeft a+                          , tsStripRight  = tsStripRight b <|> tsStripRight a+                          , tsUW          = tsUW b <|> tsUW a+                          , tsNotNormalize = tsNotNormalize b <|> tsNotNormalize a+                          , tsEsc         = tsEsc b <|> tsEsc a+                          , tsAddEmptyFields = tsAddEmptyFields b <|> tsAddEmptyFields a+                          , tsPunct = tsPunct b <> tsPunct a+                          , tsIndent = tsIndent b <|> tsIndent a+                          , tsItabStops = tsItabStops b <|> tsItabStops a+                          , tsKeywords = tsKeywords b <> tsKeywords a+                          }++instance Monoid TokenizeSpec where+  mempty = TokenizeSpec { tsAtoms = mempty+                        , tsStringQQ = Nothing+                        , tsStringQ  = Nothing+                        , tsNoSlits = Nothing+                        , tsLineComment = mempty+                        , tsDelims = mempty+                        , tsEol = Nothing+                        , tsStripLeft = Nothing+                        , tsStripRight = Nothing+                        , tsUW = Nothing+                        , tsNotNormalize = Nothing+                        , tsEsc = Nothing+                        , tsAddEmptyFields = Nothing+                        , tsPunct = mempty+                        , tsIndent = Nothing+                        , tsItabStops = Nothing+                        , tsKeywords = mempty+                        }+++justTrue :: Maybe Bool -> Bool+justTrue (Just True) = True+justTrue _ = False++-- | Turns on EOL token generation+eol :: TokenizeSpec+eol = mempty { tsEol = pure True }++-- | Turn on character escaping inside string literals.+-- Currently the following escaped characters are+-- supported: [" ' \ t n r a b f v ]+esc :: TokenizeSpec+esc = mempty { tsEsc = pure True }++-- | Raise empty field tokens (note mkEmpty method)+-- when no tokens found before a delimeter.+-- Useful for processing CSV-like data in+-- order to distingush empty columns+addEmptyFields :: TokenizeSpec+addEmptyFields = mempty { tsAddEmptyFields = pure True }++-- | same as addEmptyFields+emptyFields :: TokenizeSpec+emptyFields = addEmptyFields++-- | Turns off token normalization. Makes the tokenizer+-- generate character stream. Useful for debugging.+nn :: TokenizeSpec+nn = mempty { tsNotNormalize = pure True }++-- | Turns on single-quoted string literals.+-- Character stream after '\'' character+-- will be proceesed as single-quoted stream,+-- assuming all delimeter, comment and other special+-- characters as a part of the string literal until+-- the next unescaped single quote character.+sq :: TokenizeSpec+sq = mempty { tsStringQ = pure True }++-- | Enable double-quoted string literals support+-- as 'sq' for single-quoted strings.+sqq :: TokenizeSpec+sqq = mempty { tsStringQQ = pure True }++-- | Disable separate string literals.+--+-- Useful when processed delimeted data (csv-like formats).+-- Normally, sequential text chunks are concatenated together,+-- but consequent text and string literal will produce the two+-- different tokens and it may cause weird results if data+-- is in csv-like format, i.e:+--+-- >>> tokenize (delims ":"<>emptyFields<>sq ) "aaa:bebe:'qq' aaa:next::" :: [Maybe Text]+-- [Just "aaa",Just "bebe",Just "qq",Just " aaa",Just "next",Nothing,Nothing]+--+-- look: "qq" and " aaa" are turned into two separate tokens that makes the result+-- of CSV processing looks improper, like it has an extra-column. This behavior may be+-- avoided using this option, if you don't need to distinguish text chunks and string+-- literals:+--+-- >>> tokenize (delims ":"<>emptyFields<>sq<>noslits) "aaa:bebe:'qq:foo' aaa:next::" :: [Maybe Text]+-- [Just "aaa",Just "bebe",Just "qq:foo aaa",Just "next",Nothing,Nothing]+--+noslits :: TokenizeSpec+noslits = mempty { tsNoSlits = pure True }++-- | Specify the list of delimers (characters)+-- to split the character stream into fields.  Useful for CSV-like separated formats.  Support for+-- empty fields in token stream may be enabled by 'addEmptyFields' function+delims :: String -> TokenizeSpec+delims s = mempty { tsDelims = Set.fromList s }++-- | Strip spaces on left side of a token.+-- Does not affect string literals, i.e string are processed normally. Useful mostly for+-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.+sl :: TokenizeSpec+sl = mempty { tsStripLeft = pure True }++-- | Strip spaces on right side of a token.+-- Does not affect string literals, i.e string are processed normally. Useful mostly for+-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.+sr :: TokenizeSpec+sr = mempty { tsStripRight = pure True }++-- | Strips spaces on right and left sides and transforms multiple spaces into the one.+-- Name origins from  unwords . words+--+-- Does not affect string literals, i.e string are processed normally. Useful mostly for+-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.+uw :: TokenizeSpec+uw = mempty { tsUW = pure True }++-- | Specify the line comment prefix.+-- All text after the line comment prefix will+-- be ignored until the newline character appearance.+-- Multiple line comments are supported.+comment :: Text -> TokenizeSpec+comment s = mempty { tsLineComment = cmt }+  where+    cmt = case Text.uncons s of+            Just (p,su) -> Map.singleton p su+            Nothing     -> mempty++-- | Specify the punctuation characters.+-- Any punctuation character is handled as a separate+-- token.+-- Any token will be breaked on a punctiation character.+--+-- Useful for handling ... er... punctuaton, like+--+-- >> function(a,b)+--+-- or+--+-- >> (apply function 1 2 3)+--+--+-- >>> tokenize spec "(apply function 1 2 3)" :: [Text]+-- ["(","apply","function","1","2","3",")"]+--+punct :: Text -> TokenizeSpec+punct s = mempty { tsPunct = Set.fromList (Text.unpack s) }++-- | Specify the keywords list.+-- Each keyword will be threated as a separate token.+keywords :: [Text] -> TokenizeSpec+keywords s = mempty { tsKeywords = Set.fromList s }++-- | Enable identation support+indent :: TokenizeSpec+indent = mempty { tsIndent = Just True }++-- | Set tab expanding multiplier+-- i.e. each tab extends into n spaces before processing.+-- It also turns on the indentation. Only the tabs at the beginning of the string are expanded,+-- i.e. before the first non-space character appears.+itabstops :: Int -> TokenizeSpec+itabstops n = mempty { tsIndent = Just True, tsItabStops = pure n }++newtype TokenizeM w a = TokenizeM (RWS TokenizeSpec w () a)+                        deriving( Applicative+                                , Functor+                                , MonadReader TokenizeSpec+                                , MonadWriter w+                                , MonadState  ()+                                , Monad+                                )++data Token = TChar Char+           | TSChar Char+           | TPunct Char+           | TText Text+           | TSLit Text+           | TKeyword Text+           | TEmpty+           | TDelim+           | TIndent Int+           | TEol+           deriving (Eq,Ord,Show)++-- | Typeclass for token values.+-- Note, that some tokens appear in results+-- only when 'nn' option is set, i.e. sequences+-- of characters turn out to text tokens or string literals+-- and delimeter tokens are just removed from the+-- results+class IsToken a where+  -- |  Create a character token+  mkChar   :: Char -> a+  -- | Create a string literal character token+  mkSChar  :: Char -> a+  -- | Create a punctuation token+  mkPunct  :: Char -> a+  -- | Create a text chunk token+  mkText   :: Text -> a+  -- | Create a string literal token+  mkStrLit :: Text -> a+  -- | Create a keyword token+  mkKeyword :: Text -> a+  -- | Create an empty field token+  mkEmpty  :: a+  -- | Create a delimeter token+  mkDelim  :: a+  mkDelim = mkEmpty++  -- | Creates an indent token+  mkIndent :: Int -> a+  mkIndent = const mkEmpty++  -- | Creates an EOL token+  mkEol :: a+  mkEol = mkEmpty++instance IsToken (Maybe Text) where+  mkChar = pure . Text.singleton+  mkSChar = pure . Text.singleton+  mkPunct = pure . Text.singleton+  mkText = pure+  mkStrLit = pure+  mkKeyword = pure+  mkEmpty = Nothing++instance IsToken Text where+  mkChar   = Text.singleton+  mkSChar  = Text.singleton+  mkPunct  = Text.singleton+  mkText   = id+  mkStrLit = id+  mkKeyword = id+  mkEmpty  = ""++-- | Tokenize a text+tokenize :: IsToken a => TokenizeSpec -> Text -> [a]+tokenize s t = map tr t1+  where+    t1 = tokenize' s t+    tr (TChar c) = mkChar c+    tr (TSChar c) = mkSChar c+    tr (TText c) = mkText c+    tr (TSLit c) = mkStrLit c+    tr (TKeyword c) = mkKeyword c+    tr TEmpty  = mkEmpty+    tr (TPunct c) = mkPunct c+    tr TDelim  = mkDelim+    tr (TIndent n) = mkIndent n+    tr TEol = mkEol++execTokenizeM :: TokenizeM [Token] a -> TokenizeSpec -> [Token]+execTokenizeM (TokenizeM m) spec =+  let (_,w) = execRWS m spec () in norm w++  where norm x | justTrue (tsNotNormalize spec) = x+               | otherwise = normalize spec x++tokenize' :: TokenizeSpec -> Text -> [Token]+tokenize' spec txt = execTokenizeM (root' txt) spec+  where++    r = spec++    noIndent = not doIndent+    doIndent = justTrue (tsIndent r)+    eolOk = justTrue (tsEol r)++    root' x = scanIndent x >>= root++    root ts = do++      case Text.uncons ts of+        Nothing           -> pure ()++        Just ('\n', rest) | doIndent                  -> raiseEol >> root' rest+        Just (c, rest)    | Set.member c (tsDelims r) -> tell [TDelim]  >> root rest+        Just ('\'', rest) | justTrue (tsStringQ r)    -> scanQ '\'' rest+        Just ('"', rest)  | justTrue (tsStringQQ r)   -> scanQ '"' rest++        Just (c, rest)    | Map.member c (tsLineComment r) -> scanComment (c,rest)++        Just (c, rest)    | Set.member c (tsPunct r)  -> tell [TPunct c] >> root rest++        Just (c, rest)    | otherwise                 -> tell [TChar c] >> root rest+++    raiseEol | eolOk = tell [TEol]+             | otherwise = pure ()++    expandSpace ' '  = 1+    expandSpace '\t' = (fromMaybe 8 (tsItabStops r))+    expandSpace _    = 0++    scanIndent x | noIndent = pure x+                 | otherwise = do+      let (ss,as) = Text.span (\c -> c == ' ' || c == '\t') x+      tell [ TIndent (sum (map expandSpace (Text.unpack ss))) ]+      pure as++    scanComment (c,rest) = do+      suff <- Map.lookup c <$> asks tsLineComment+      case suff of+        Just t | Text.isPrefixOf t rest -> do+           root $ Text.dropWhile ('\n' /=) rest++        _  -> tell [TChar c] >> root rest++    scanQ q ts = do++      case Text.uncons ts of+        Nothing           -> root ts++        Just ('\\', rest) | justTrue (tsEsc r) -> unesc (scanQ q) rest+                          | otherwise          -> tell [tsChar '\\'] >> scanQ q rest++        Just (c, rest) | c ==  q   -> root rest+                       | otherwise -> tell [tsChar c] >> scanQ q rest++    unesc f ts = do+      case Char.readLitChar ('\\' : Text.unpack ts) of+        [ (c, rest) ] -> tell [tsChar c] >> f (Text.pack rest)+        _             -> f ts++    tsChar c | justTrue (tsNoSlits spec) = TChar c+             | otherwise = TSChar c++newtype NormStats = NormStats { nstatBeforeDelim :: Int }++normalize :: TokenizeSpec -> [Token] -> [Token]+normalize spec tokens = snd $ execRWS (go tokens) () init+  where++    go [] = addEmptyField++    go s@(TIndent _ : _) = do+      let (iis, rest') = List.span isIndent s+      tell [TIndent (sum [k | TIndent k <- iis])]+      go rest'++    go (TChar c0 : cs) = do+      let (n,ns) = List.span isTChar cs+      succStat+      let chunk = eatSpaces $ Text.pack (c0 : [ c | TChar c <- n])+      let kw = Set.member chunk (tsKeywords spec)+      tell [ if kw then TKeyword chunk else TText chunk ]+      go ns++    go (TSChar x : xs) = do+      let (n,ns) = List.span isTSChar xs+      succStat+      tell [ TSLit $ Text.pack (x : [ c | TSChar c <- n]) ]+      go ns++    go (TDelim : xs) = do+      addEmptyField+      pruneStat+      go xs++    go (TPunct c : xs) = do+      tell [ TPunct c ]+      succStat+      go xs++    go (x:xs) = tell [x] >> go xs++    succStat = do+      modify (\x -> x { nstatBeforeDelim = succ (nstatBeforeDelim x)})++    pruneStat = do+      modify (\x -> x { nstatBeforeDelim = 0 } )++    addEmptyField = do+      ns <- gets nstatBeforeDelim+      when  (ns == 0 && justTrue (tsAddEmptyFields spec) ) $ do+        tell [ TEmpty ]++    isTChar (TChar _) = True+    isTChar _         = False++    isTSChar (TSChar _) = True+    isTSChar _          = False++    isIndent (TIndent _) = True+    isIndent _           = False++    init = NormStats { nstatBeforeDelim = 0 }++    eatSpaces s | sboth  = Text.strip s+                | sLonly = Text.stripStart s+                | sRonly = Text.stripEnd s+                | sWU    = (Text.unwords . Text.words) s+                | otherwise = s++      where sboth  = justTrue (tsStripLeft spec) && justTrue (tsStripRight spec)+            sLonly = justTrue (tsStripLeft spec) && not (justTrue (tsStripRight spec))+            sRonly = not (justTrue (tsStripLeft spec)) && justTrue (tsStripRight spec)+            sWU    = justTrue (tsUW spec)+
+ suckless-conf.cabal view
@@ -0,0 +1,183 @@+cabal-version:      3.0+name:               suckless-conf+version:            0.1.2.9+synopsis:           S-expression configuration language and the bf6 script runtime+description:+    @suckless-conf@ is a small Lisp-like, s-expression configuration+    language with an embedded scripting layer. It parses configuration+    files into a simple @Syntax@ tree, offers a key-value access layer+    and bridges to Aeson, TOML, YAML and INI, and ships a tiny+    interpreter (@Data.Config.Suckless.Script@) that evaluates the same+    syntax as a script. The package also installs @bf6@, the standalone+    script runtime that the <https://github.com/NCrashed/hbs2 hbs2>+    project uses via a shebang for its tooling.++    Originally written by Dmitry Zuykov (voidlizard) for the @hbs2@+    project, this Hackage release is published from+    <https://github.com/NCrashed/suckless-conf> so downstream projects+    can depend on it without vendoring.++    The s-expression tokenizer and reader (@Data.Text.Fuzzy.Tokenize@+    and @Data.Text.Fuzzy.SExp@) are bundled as internal modules,+    derived from the MIT-licensed @fuzzy-parse@ package.+license:            BSD-3-Clause AND MIT+license-files:      LICENSE+                    LICENSE.fuzzy-parse+author:             Dmitry Zuykov+maintainer:         Anton Gushcha <ncrashed@gmail.com>+copyright:          (c) Dmitry Zuykov 2023, (c) Anton Gushcha 2026+category:           Text+build-type:         Simple+tested-with:        GHC == 9.6.6+extra-doc-files:    CHANGELOG.md+                    README.md+extra-source-files: t/key-value-test-config+homepage:           https://github.com/NCrashed/suckless-conf+bug-reports:        https://github.com/NCrashed/suckless-conf/issues++source-repository head+  type:     git+  location: https://github.com/NCrashed/suckless-conf.git++common shared-properties+  ghc-options:+        -Wall++  default-language:    Haskell2010++  default-extensions:+                       ApplicativeDo+                     , BangPatterns+                     , BlockArguments+                     , ConstraintKinds+                     , DataKinds+                     , DeriveDataTypeable+                     , DeriveGeneric+                     , DerivingStrategies+                     , DerivingVia+                     , ExtendedDefaultRules+                     , FlexibleContexts+                     , FlexibleInstances+                     , GADTs+                     , GeneralizedNewtypeDeriving+                     , ImportQualifiedPost+                     , LambdaCase+                     , MultiParamTypeClasses+                     , OverloadedStrings+                     , QuasiQuotes+                     , ScopedTypeVariables+                     , StandaloneDeriving+                     , TupleSections+                     , TypeApplications+                     , TypeFamilies+++library+    import:          shared-properties++    exposed-modules:+        Data.Config.Suckless+      , Data.Config.Suckless.Syntax+      , Data.Config.Suckless.Parse+      , Data.Config.Suckless.Parse.Fuzzy+      , Data.Config.Suckless.KeyValue+      , Data.Config.Suckless.System+      , Data.Config.Suckless.Script+      , Data.Config.Suckless.Script.File+      , Data.Config.Suckless.Script.Internal+      , Data.Config.Suckless.Almost.RPC++    other-modules:+        Data.Config.Suckless.Types+      , Data.Text.Fuzzy.Tokenize+      , Data.Text.Fuzzy.SExp++    build-depends:    base                        >= 4.17     && < 5+                    , aeson                       >= 2.1      && < 2.3+                    , bytestring                  >= 0.11     && < 0.13+                    , containers                  >= 0.6      && < 0.8+                    , directory                   >= 1.3      && < 1.4+                    , filepath                    >= 1.4      && < 1.6+                    , filepattern                 >= 0.1      && < 0.2+                    , hashable                    >= 1.4      && < 1.6+                    , html-entities               >= 1.1      && < 1.2+                    , ini                         >= 0.4      && < 0.5+                    , interpolatedstring-perl6    >= 1.0      && < 1.1+                    , microlens-platform          >= 0.4      && < 0.5+                    , mtl                         >= 2.3      && < 2.4+                    , prettyprinter               >= 1.7      && < 1.8+                    , prettyprinter-ansi-terminal >= 1.1      && < 1.2+                    , random                      >= 1.2      && < 1.3+                    , random-shuffle              >= 0.0.4    && < 0.1+                    , safe                        >= 0.3      && < 0.4+                    , scientific                  >= 0.3      && < 0.4+                    , streaming                   >= 0.2      && < 0.3+                    , split                       >= 0.2      && < 0.3+                    , stm                         >= 2.5      && < 2.6+                    , text                        >= 2.0      && < 2.2+                    , time                        >= 1.12     && < 1.13+                    , transformers                >= 0.6      && < 0.7+                    , toml-parser                 >= 1.3      && < 1.4+                    , typed-process               >= 0.2      && < 0.3+                    , temporary                   >= 1.3      && < 1.4+                    , uniplate                    >= 1.6      && < 1.7+                    , unliftio                    >= 0.2      && < 0.3+                    , unordered-containers        >= 0.2      && < 0.3+                    , uuid                        >= 1.3      && < 1.4+                    , vector                      >= 0.13     && < 0.14+                    , yaml                        >= 0.11     && < 0.12++    hs-source-dirs:   lib+++executable bf6+    import:           shared-properties+    main-is:          Main.hs+    ghc-options:+        -threaded+        -rtsopts+        "-with-rtsopts=-N4 -A64m -AL256m -I0"+    build-depends:+          base, unliftio, suckless-conf, safe++    hs-source-dirs:   bf6+    default-language: GHC2021+++test-suite spec+  import:          shared-properties+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.Config.Suckless.KeyValueSpec+      Data.Config.Suckless.AesonSpec++  hs-source-dirs:+      test+  ghc-options:+      -Wall+      -threaded+      -rtsopts+      -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:      base+                    , hspec+                    , aeson+                    , scientific+                    , suckless-conf+                    , containers+                    , mtl+                    , text+                    , prettyprinter+                    , interpolatedstring-perl6+                    , tasty-hunit++  default-language: Haskell2010+  default-extensions:+                      DerivingStrategies+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , OverloadedStrings+                    , ScopedTypeVariables+                    , TypeApplications
+ t/key-value-test-config view
@@ -0,0 +1,34 @@+; comment+foo "a"+bar "a"+bar "b"++int1 122+int2  0+int3 -22+int4 0xFAFA+int5 0b11111111+int6 -0xFAFA++(jopa-kita)++(sci1 1e9)+(sci2 0.003)+(sci3 -0.001)+(sci4 -2e11)+(sci5 -2e-3)++(wtf1 .001)++some-object {object ( key : 42) }++{another-object+  (object+    ( key1 : 42 )+    ( key2 : #f )+    ( key3 : [ 1 2 3 4 ] )+  )+}+++
+ test/Data/Config/Suckless/AesonSpec.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+++{-# OPTIONS_GHC -Wno-orphans #-}+module Data.Config.Suckless.AesonSpec (spec) where++import Data.Config.Suckless.KeyValue+import Data.Config.Suckless.Parse+import Data.Config.Suckless.Syntax+import Data.Functor+import Data.Function+import Data.Scientific+import Data.Text (Text)+import Data.Text.IO qualified as Text++import GHC.Generics hiding (C)+import Text.InterpolatedString.Perl6 (qc,q)+import Data.Aeson+import Data.Maybe+import Control.Monad.Reader+import Test.Hspec+import Test.Tasty.HUnit+import Prettyprinter+++readConfig :: Text -> IO [Syntax C]+readConfig s = do+  pure $ parseTop s & either mempty id+  -- print $ pretty f+  -- pure f++data SomeData =+  SomeData+  { someDataKey1 :: Int+  , someDataKey2 :: String+  , someDataKey3 :: [Scientific]+  }+  deriving stock (Generic,Show,Eq)++instance ToJSON SomeData+instance FromJSON SomeData++data Port+data Users++instance HasCfgKey Port (Maybe Int)+  where key = "port"++instance HasCfgKey Users [Value]+  where key = "basic-users"++spec :: Spec+spec = do+  describe "toJSON" $ do++    it "reads int" $ do+      c <- readConfig [qc|1|] <&> toJSON+      c `shouldBe` toJSON [[1::Int]]++    it "reads scientific" $ do+      c <- readConfig [qc|1.00|] <&> toJSON+      c `shouldBe` toJSON [[1.00 :: Scientific]]++    it "reads bool" $ do+      t <- readConfig [qc|#t|]  <&> toJSON . head+      t `shouldBe` toJSON [Bool True]+      f <- readConfig [qc|#f|] <&> toJSON . head+      f `shouldBe` toJSON [Bool False]++    it "reads string" $ do+      s <- readConfig [qc|"somestring"|] <&> toJSON+      s `shouldBe` toJSON [["somestring" :: String]]++    it "reads array" $ do+      s <- readConfig [qc|(1 2 3 4)|] <&> toJSON . head+      print s+      s `shouldBe` toJSON [1::Int,2,3,4]++    it "reads simple object" $ do+      s <- readConfig [qc|+        (object+            (key1 : 22)+            (key2 : #f)+            (key3 : [1 2 3 4])+            (key4 : (object (o1 : "bebe")) )+            ("fafa" : "fifa")+            (none : #nil)+        )+      |] <&> toJSON . head++      let s1 = decode @Value [q|+        {+            "key1": 22,+            "key2": false,+            "key3": [1, 2, 3, 4],+            "key4": {+                "o1": "bebe"+            },+            "fafa" : "fifa",+            "none" : null+        }++      |]++      print s+      print s1+      Just s `shouldBe` s1+++    it "serializes object to syntax"  $ do+      let some = SomeData 1 "some-data" [1, 2, 3, 4, 5, 10]++      let someSyn = case fromJSON @(Syntax ()) (toJSON some) of+                      Success syn -> Just syn+                      _           -> Nothing++      print $ pretty someSyn++      let json = fromJust $ someSyn <&> toJSON++      let someObject = fromJSON @SomeData json++      print someObject+      someObject `shouldBe` Success some++    it "read-real-config" do+      let cfg = [q|++port 3000++hbs2-url "http://localhost:5001"++default-token-name "LCOIN"++hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/hbs2.key"++; old test thermoland reflog+hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/termoland-reflog-GX8gmPi2cAxxgnaKmLmR5iViup1BNkwpdCCub3snLT1y.key"++; new test thermoland reflog+hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/termoland-reflog-AdowWzo4iW1JejHFRnPnxQWNot8uL5sciFup6RHx2gZG.key"++++hbs2-keyring "/home/hbs2/keys/lcoin-belorusskaya-JAiAjKzfWfTGXjuSf4GXaj44cWfDQ8vifxoQU3tq5hn7.key"+hbs2-keyring "/home/hbs2/keys/lcoin-krymskaya-CEDBX2niVK3YL7WxzLR3xj8iUNHa9GU2EfXUqDU7fSGK.key"+hbs2-keyring "/home/hbs2/keys/lcoin-ushakova-GyTXGiCUJu81CMXYZzs7RhHu4vxJnLYgT3n2neXG5uaY.key"+hbs2-keyring "/home/hbs2/keys/lcoin-zelenopark-4fFvFGzQRp2WSXtDHepeJvMtCfQdSASq9qmsELWRJDgv.key"++++jwk-path "/home/hbs2/lcoin-adapter/secrets/jwk/public_key.jwk"++jwk-path "/home/hbs2/lcoin-adapter/secrets/jwk/public-key-2023-11-03.jwk"++lcoin-rate 5++db-path "/home/hbs2/.local/share/lcoin-adapter/state.db"++registration-bonus 500++log-file "/home/hbs2/lcoin-adapter/log.txt"++; qblf-socket  "/tmp/qblf.socket"++qblf-treasure "64zvWqGUf57WmGCTFWrVaNEqXikUocGyKFtg5mhyWCiB"++reports-ignore-key "DyKWNLvpRSsTsJfVxTciqxnCJ6UhF4Mf6WoMw5qkftG4"+reports-ignore-key "3MjGvpffawUijHxbbsaF9J6wt4YReRdArUCTfHo1RhSm"+++;; v2+db-journal "/tmp/lcoin-adapter-journal.sqlite"+db-cache "/tmp/lcoin-adapter-cache-db.sqlite"+hbs2-store "/tmp/hbs2-store"++treasure "64zvWqGUf57WmGCTFWrVaNEqXikUocGyKFtg5mhyWCiB"++keybox "http://localhost:8034/"+dev-env false+(jwk-keys (+    "/home/hbs2/lcoin-adapter/secrets/jwk/public_key.jwk"+    "/home/hbs2/lcoin-adapter/secrets/jwk/public-key-2023-11-03.jwk"+    ))++(basic-users (+    (object (name "mobile") (pass "mobile-pass"))+    (object (name "termo") (pass "termo-pass"))+    ))++(client-creator "BYVqWJdn18Q3AjmJBPw2yusZ5ouNmgiRydWQgBEh684J")+(client-creator-keyring "/home/hbs2/keys/journal/client-creator_BYVqWJdn18Q3AjmJBPw2yusZ5ouNmgiRydWQgBEh684J.key")++(coin-minter "4Gnno5yXUbT5dwfphKtDW7dWeq4uBvassSdbVvB3y67p")+(coin-minter-keyring "/home/hbs2/keys/journal/coin-minter_4Gnno5yXUbT5dwfphKtDW7dWeq4uBvassSdbVvB3y67p.key")+      |] :: Text+++      let what = parseTop cfg & either (error.show) id++      let pno = runReader (cfgValue @Port @(Maybe Int)) what+      -- what++      assertEqual "pno" pno (Just 3000)+++
+ test/Data/Config/Suckless/KeyValueSpec.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Config.Suckless.KeyValueSpec (spec) where++import Data.Function+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Config.Suckless.KeyValue+import Data.Config.Suckless.Parse+import Data.Config.Suckless.Syntax+import Data.Functor+import Data.Scientific+import Data.Text.IO qualified as Text+import Data.Set (Set)+import qualified Data.Set as Set+import Prettyprinter+import Data.Aeson+import Text.InterpolatedString.Perl6 (qc,q)+import Test.Hspec+++data FirstKey++data SecondKey++data ThirdKey++data Int1+data Int2+data Int3+data Int4+data Int5+data Int6++data Sci1+data Sci2+data Sci3+data Sci4+data Sci5++data O1+data O2++instance HasCfgKey FirstKey (Maybe String) where+  key = "foo"++instance HasCfgKey SecondKey (Set String) where+  key = "bar"++instance HasCfgKey ThirdKey (Maybe String) where+  key = "baz"++instance HasCfgKey Int1 b where+  key = "int1"++instance HasCfgKey Int2 b where+  key = "int2"++instance HasCfgKey Int3 b where+  key = "int3"++instance HasCfgKey Int4 b  where+  key = "int4"++instance HasCfgKey Int5 b where+  key = "int5"++instance HasCfgKey Int6 b where+  key = "int6"++instance HasCfgKey Sci1 b where+  key = "sci1"++instance HasCfgKey Sci2 b where+  key = "sci2"++instance HasCfgKey Sci3 b where+  key = "sci3"++instance HasCfgKey Sci4 b where+  key = "sci4"++instance HasCfgKey Sci5 b where+  key = "sci5"++instance HasCfgKey O1 b where+  key = "some-object"++instance HasCfgKey O2 b where+  key = "another-object"++instance HasConf IO where+  getConf = liftIO readConfig++readConfig :: IO [Syntax C]+readConfig = do+  let configFilePath = "t/key-value-test-config"+  f <- Text.readFile configFilePath <&> parseTop <&> either mempty id+  print $ pretty f+  pure f++spec :: Spec+spec = do+  describe "config parsing" $ do++    it "reads string" $ do+      firstValue <- cfgValue @FirstKey @(Maybe String)+      firstValue `shouldBe` Just "a"++    it "reads a set of strings" $ do+      secondValue <- cfgValue @SecondKey @(Set String)+      secondValue `shouldBe` Set.fromList ["a", "b"]++    it "reads nothing" $ do+      thridValue <- cfgValue @ThirdKey @(Maybe String)+      thridValue `shouldBe` Nothing++    it "reads ints" $ do+      x1 <- cfgValue @Int1 @(Maybe Integer)+      x1 `shouldBe` Just 122++      x2 <- cfgValue @Int2+      x2 `shouldBe` Just (0 :: Integer)++      x3 <- cfgValue @Int3+      x3 `shouldBe` Just (-22 :: Integer)++      x4 <- cfgValue @Int4 @(Maybe Integer)+      x4 `shouldBe` Just 0xFAFA++      x5 <- cfgValue @Int5 @(Maybe Integer)+      x5 `shouldBe` Just 255++      x6 <- cfgValue @Int6 @(Maybe Integer)+      x6 `shouldBe` Just (-0xFAFA)++    it "reads scientifics" $ do+      x1 <- cfgValue @Sci1 @(Maybe Scientific)+      x1 `shouldBe` Just 1e9++      x2 <- cfgValue @Sci2 @(Maybe Scientific)+      x2 `shouldBe` Just 0.003++      -- x3 <- cfgValue @Sci3 @(Maybe Scientific)+      -- x3 `shouldBe` Just (-0.001)++      x4 <- cfgValue @Sci4 @(Maybe Scientific)+      x4 `shouldBe` Just (-2e11)++      x5 <- cfgValue @Sci5 @(Maybe Scientific)+      x5 `shouldBe` Just (-2e-3)++    it "reads objects" $ do+      o1 <- cfgValue @O1 @(Maybe Value)+      let wtf1 = [q|{ "key" : 42 }|]+      o1 `shouldBe` decode wtf1+      let wtf2 = [q|+        {   "key1" : 42+          , "key2" : false+          , "key3" : [ 1, 2, 3, 4]+        }+      |]+      o2 <- cfgValue @O2 @(Maybe Value)+      o2 `shouldBe` decode wtf2+++    it "works in Reader" $ do++      let cfg = [qc|+int1 123++|]+      let conf = parseTop cfg & either mempty id++      let v = runReader (cfgValue @Int1 @(Maybe Int)) conf++      v `shouldBe` Just 123+++
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}