diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 `; original + authorship by Dmitry Zuykov is preserved. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/LICENSE.fuzzy-parse b/LICENSE.fuzzy-parse new file mode 100644 --- /dev/null +++ b/LICENSE.fuzzy-parse @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/bf6/Main.hs b/bf6/Main.hs new file mode 100644 --- /dev/null +++ b/bf6/Main.hs @@ -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 + diff --git a/lib/Data/Config/Suckless.hs b/lib/Data/Config/Suckless.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless.hs @@ -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 + + diff --git a/lib/Data/Config/Suckless/Almost/RPC.hs b/lib/Data/Config/Suckless/Almost/RPC.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Almost/RPC.hs @@ -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) + + diff --git a/lib/Data/Config/Suckless/KeyValue.hs b/lib/Data/Config/Suckless/KeyValue.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/KeyValue.hs @@ -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) + ] + + diff --git a/lib/Data/Config/Suckless/Parse.hs b/lib/Data/Config/Suckless/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Parse.hs @@ -0,0 +1,8 @@ +module Data.Config.Suckless.Parse + ( module Data.Config.Suckless.Parse.Fuzzy + ) where + +import Data.Config.Suckless.Parse.Fuzzy + + + diff --git a/lib/Data/Config/Suckless/Parse/Fuzzy.hs b/lib/Data/Config/Suckless/Parse/Fuzzy.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Parse/Fuzzy.hs @@ -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) + + + diff --git a/lib/Data/Config/Suckless/Script.hs b/lib/Data/Config/Suckless/Script.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Script.hs @@ -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' + + diff --git a/lib/Data/Config/Suckless/Script/File.hs b/lib/Data/Config/Suckless/Script/File.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Script/File.hs @@ -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) + diff --git a/lib/Data/Config/Suckless/Script/Internal.hs b/lib/Data/Config/Suckless/Script/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Script/Internal.hs @@ -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 " + $ 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 " + $ 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 " + $ 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 " + $ 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 + + diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -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 #-} + + diff --git a/lib/Data/Config/Suckless/System.hs b/lib/Data/Config/Suckless/System.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/System.hs @@ -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 + + + + diff --git a/lib/Data/Config/Suckless/Types.hs b/lib/Data/Config/Suckless/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Config/Suckless/Types.hs @@ -0,0 +1,1 @@ +module Data.Config.Suckless.Types where diff --git a/lib/Data/Text/Fuzzy/SExp.hs b/lib/Data/Text/Fuzzy/SExp.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/Fuzzy/SExp.hs @@ -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 + diff --git a/lib/Data/Text/Fuzzy/Tokenize.hs b/lib/Data/Text/Fuzzy/Tokenize.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Text/Fuzzy/Tokenize.hs @@ -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) + diff --git a/suckless-conf.cabal b/suckless-conf.cabal new file mode 100644 --- /dev/null +++ b/suckless-conf.cabal @@ -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 + project uses via a shebang for its tooling. + + Originally written by Dmitry Zuykov (voidlizard) for the @hbs2@ + project, this Hackage release is published from + 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 +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 diff --git a/t/key-value-test-config b/t/key-value-test-config new file mode 100644 --- /dev/null +++ b/t/key-value-test-config @@ -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 ] ) + ) +} + + + diff --git a/test/Data/Config/Suckless/AesonSpec.hs b/test/Data/Config/Suckless/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Config/Suckless/AesonSpec.hs @@ -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) + + + diff --git a/test/Data/Config/Suckless/KeyValueSpec.hs b/test/Data/Config/Suckless/KeyValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Config/Suckless/KeyValueSpec.hs @@ -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 + + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}