voidlizard
/
suckless-conf
mirror of https://github.com/voidlizard/suckless-conf.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Compare commits

base: voidlizard:master
Branches Tags
voidlizard:master
voidlizard:stable-1.01
voidlizard:0.1.2.9
voidlizard:0.1.2.8
voidlizard:0.1.2.7
voidlizard:0.1.2.6
voidlizard:0.1.2.4
voidlizard:0.1.2.3
voidlizard:0.1.2.2
voidlizard:0.1.2.1
voidlizard:0.1.2.0
..
compare: voidlizard:0.1.2.4
Branches Tags
voidlizard:master
voidlizard:stable-1.01
voidlizard:0.1.2.9
voidlizard:0.1.2.8
voidlizard:0.1.2.7
voidlizard:0.1.2.6
voidlizard:0.1.2.4
voidlizard:0.1.2.3
voidlizard:0.1.2.2
voidlizard:0.1.2.1
voidlizard:0.1.2.0

No commits in common. "master" and "0.1.2.4" have entirely different histories.
master ... 0.1.2.4

10 changed files with 36 additions and 1662 deletions
Show Stats Expand all files Collapse all files

39
flake.lock
View File

@ -36,18 +36,19 @@
"nixpkgs": "nixpkgs"
},
"locked": {
"lastModified": 1737544489,
"narHash": "sha256-prTXYnEgUIIe5nMaE3rC9g6Ej3qtAKudd8T/QA+eyW8=",
"ref": "refs/heads/master",
"rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
"revCount": 46,
"lastModified": 1715856223,
"narHash": "sha256-Q9I6YbvzGuV9yHtxGxxU10LMQf9AdcsecSszPT7PDuc=",
"ref": "sexp-parser",
"rev": "b0a7f96d6569d16b0d27c2f9477d94e5ee39df66",
"revCount": 62,
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
"url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
},
"original": {
"rev": "9e41a735a8bdb02b2b5c405341d8b3b98242f021",
"ref": "sexp-parser",
"rev": "b0a7f96d6569d16b0d27c2f9477d94e5ee39df66",
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
"url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
}
},
"haskell-flake-utils": {
@ -73,11 +74,11 @@
"flake-utils": "flake-utils_2"
},
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
},
"original": {
@ -88,33 +89,33 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1727089097,
"narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixpkgs-unstable",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1727089097,
"narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixpkgs-unstable",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
}
},

4
flake.nix
View File

@ -2,12 +2,12 @@
description = "suckless-cong: sexp based configs";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
nixpkgs.url = "github:NixOS/nixpkgs?rev=442d407992384ed9c0e6d352de75b69079904e4e";
haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
fuzzy.url =
# "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=bd3a38904864d5cc333974e7b029412607b46871";
"git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?rev=9e41a735a8bdb02b2b5c405341d8b3b98242f021";
"git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=b0a7f96d6569d16b0d27c2f9477d94e5ee39df66";
};

1
lib/Data/Config/Suckless.hs
View File

@ -9,4 +9,3 @@ import Data.Config.Suckless.Syntax
import Data.Config.Suckless.Parse
import Data.Config.Suckless.KeyValue

47
lib/Data/Config/Suckless/Almost/RPC.hs
View File

@ -1,47 +0,0 @@
{-# Language TypeOperators #-}
module Data.Config.Suckless.Almost.RPC where
import Data.Config.Suckless
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString.Lazy as LBS
import Data.ByteString.Lazy.Char8 as LBS8
import Data.Function
import Data.Text.Encoding.Error qualified as TE
import Data.Text.Encoding qualified as TE
import Data.Text qualified as T
import Data.Typeable
import Prettyprinter
import System.Process.Typed
data CallProcException =
CallProcException ExitCode
deriving (Show,Typeable)
instance Exception CallProcException
-- FIXME: to-suckless-script
callProc :: forall m . (MonadIO m)
=> FilePath
-> [String]
-> [Syntax C]
-> m [Syntax C]
callProc name params syn = do
let input = fmap (LBS.fromStrict . TE.encodeUtf8 . T.pack . show . pretty) syn
& LBS8.unlines
& byteStringInput
let what = proc name params & setStderr closed & setStdin input
(code, i, _) <- readProcess what
unless (code == ExitSuccess) do
liftIO $ throwIO (CallProcException code)
let s = TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i)
parseTop s & either (liftIO . throwIO) pure

74
lib/Data/Config/Suckless/Script.hs
View File

@ -1,74 +0,0 @@
{-# 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
man <- ask >>= readTVarIO
<&> HM.lookup what
<&> maybe mzero bindMan
liftIO $ hPutDoc stdout (pretty man)
pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
splitOpts :: [(Id,Int)]
-> [Syntax C]
-> ([Syntax C], [Syntax C])
splitOpts def opts' = flip fix (mempty, opts) $ \go -> \case
(acc, []) -> acc
( (o,a), r@(StringLike x) : rs ) -> do
case HM.lookup (fromString x) omap of
Nothing -> go ((o, a <> [r]), rs)
Just n -> do
let (w, rest) = List.splitAt n rs
let result = mkList @C ( r : w )
go ( (o <> [result], a), rest )
( (o,a), r : rs ) -> do
go ((o, a <> [r]), rs)
where
omap = HM.fromList [ (p, x) | (p,x) <- def ]
opts = opts'

87
lib/Data/Config/Suckless/Script/File.hs
View File

@ -1,87 +0,0 @@
{-# 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
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)

1268
lib/Data/Config/Suckless/Script/Internal.hs
View File

File diff suppressed because it is too large Load Diff

142
lib/Data/Config/Suckless/Syntax.hs
View File

@ -2,65 +2,39 @@
{-# 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(..)
, pattern SymbolVal
, pattern ListVal
, pattern LitIntVal
, pattern LitStrVal
, pattern LitBoolVal
, pattern LitScientificVal
, pattern StringLike
, pattern TextLike
, pattern StringLikeList
, pattern Nil
, pattern OpaqueVal
)
where
import Data.Data
import Data.Dynamic
import Data.Kind
import Data.String
import Data.Text (Text)
import Data.Scientific
import GHC.Generics (Generic(..))
import Data.Maybe
-- import GHC.Generics( Fixity(..) )
-- import Data.Data as Data
import Data.Aeson
import Data.Aeson.Key
import Data.Aeson.KeyMap qualified as Aeson
import Data.Vector qualified as V
import Data.Traversable (forM)
import Data.Text qualified as Text
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Function
import Data.Functor
import Control.Applicative
import Control.Exception
import Type.Reflection
import Control.Monad.IO.Class
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Data.Word
import Prettyprinter
@ -83,55 +57,9 @@ pattern LitBoolVal v <- Literal _ (LitBool v)
pattern ListVal :: [Syntax c] -> Syntax c
pattern ListVal v <- List _ v
stringLike :: Syntax c -> Maybe String
stringLike = \case
LitStrVal s -> Just $ Text.unpack s
SymbolVal (Id s) -> Just $ Text.unpack s
_ -> Nothing
textLike :: Syntax c -> Maybe Text
textLike = \case
LitStrVal s -> Just s
SymbolVal (Id s) -> Just s
x -> Nothing
stringLikeList :: [Syntax c] -> [String]
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString
pattern StringLike :: forall {c} . String -> Syntax c
pattern StringLike e <- (stringLike -> Just e)
pattern TextLike :: forall {c} . Text -> Syntax c
pattern TextLike e <- (textLike -> Just e)
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
pattern StringLikeList e <- (stringLikeList -> e)
pattern Nil :: forall {c} . Syntax c
pattern Nil <- ListVal []
pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
pattern OpaqueVal box <- OpaqueValue box
data family Context c :: Type
isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
isOpaqueOf = \case
OpaqueValue box -> fromOpaque @a box
_ -> Nothing
isByteString :: Syntax c -> Maybe ByteStringSorts
isByteString = \case
OpaqueValue box -> do
let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy
let bs = fromOpaque @ByteString box <&> ByteStringStrict
lbs <|> bs
_ -> Nothing
class IsContext c where
noContext :: Context c
@ -147,71 +75,14 @@ class IsLiteral a where
newtype Id =
Id Text
deriving newtype (IsString,Pretty,Semigroup,Monoid)
deriving newtype (IsString,Pretty)
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
| LitBool Bool
deriving stock (Eq,Ord,Data,Generic,Show)
instance IsLiteral Text where
@ -242,14 +113,13 @@ 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)
@ -259,7 +129,6 @@ instance Pretty (Syntax c) where
pretty (Symbol _ s) = pretty s
pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) )
pretty (List _ []) = parens mempty
pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v)
instance Pretty Literal where
pretty = \case
@ -278,7 +147,6 @@ instance ToJSON Literal where
toJSON (LitBool b) = Bool b
instance ToJSON (Syntax c) where
toJSON (OpaqueValue{}) = Null
toJSON (Symbol _ (Id "#nil")) = Null
toJSON (Symbol _ (Id s)) = String s
toJSON (Literal _ l) = toJSON l

26
suckless-conf.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: suckless-conf
version: 0.1.2.9
version: 0.1.2.4
-- synopsis:
-- description:
license: BSD-3-Clause
@ -65,41 +65,24 @@ library
, Data.Config.Suckless.Syntax
, Data.Config.Suckless.Parse
, Data.Config.Suckless.KeyValue
, Data.Config.Suckless.Script
, Data.Config.Suckless.Script.File
, Data.Config.Suckless.Almost.RPC
other-modules:
Data.Config.Suckless.Types
, Data.Config.Suckless.Parse.Fuzzy
, Data.Config.Suckless.Script.Internal
-- other-extensions:
build-depends: base
, aeson
, bytestring
, containers
, directory
, filepath
, filepattern
, fuzzy-parse >= 0.1.3.1
, hashable
, interpolatedstring-perl6
, microlens-platform
, mtl
, prettyprinter
, prettyprinter-ansi-terminal
, safe
, scientific
, streaming
, stm
, text
, time
, transformers
, typed-process
, unliftio
, unordered-containers
, vector
, unordered-containers
, fuzzy-parse >= 0.1.3.0
hs-source-dirs: lib
default-language: Haskell2010
@ -126,7 +109,7 @@ test-suite spec
, aeson
, scientific
, suckless-conf
, fuzzy-parse >= 0.1.3.1
, fuzzy-parse >= 0.1.3.0
, containers
, mtl
, text
@ -142,4 +125,3 @@ test-suite spec
, OverloadedStrings
, ScopedTypeVariables
, TypeApplications

10
test/Data/Config/Suckless/AesonSpec.hs
View File

@ -60,21 +60,21 @@ spec = do
it "reads int" $ do
c <- readConfig [qc|1|] <&> toJSON
c `shouldBe` toJSON [[1::Int]]
c `shouldBe` toJSON [1::Int]
it "reads scientific" $ do
c <- readConfig [qc|1.00|] <&> toJSON
c `shouldBe` toJSON [[1.00 :: Scientific]]
c `shouldBe` toJSON [1.00 :: Scientific]
it "reads bool" $ do
t <- readConfig [qc|#t|] <&> toJSON . head
t `shouldBe` toJSON [Bool True]
t `shouldBe` toJSON (Bool True)
f <- readConfig [qc|#f|] <&> toJSON . head
f `shouldBe` toJSON [Bool False]
f `shouldBe` toJSON (Bool False)
it "reads string" $ do
s <- readConfig [qc|"somestring"|] <&> toJSON
s `shouldBe` toJSON [["somestring" :: String]]
s `shouldBe` toJSON ["somestring" :: String]
it "reads array" $ do
s <- readConfig [qc|(1 2 3 4)|] <&> toJSON . head