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

0.1.2.0

This commit is contained in:
Dmitry Zuikov 2024-05-16 14:59:26 +03:00
parent 8cfc1272bb
commit 0c5c235ed2
10 changed files with 328 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
flake.lock
View File

@ -15,10 +15,64 @@
"type": "github" "type": "github"
} }
}, },
"flake-utils_2": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"fuzzy": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils",
"nixpkgs": "nixpkgs"
},
"locked": {
"lastModified": 1715856223,
"narHash": "sha256-Q9I6YbvzGuV9yHtxGxxU10LMQf9AdcsecSszPT7PDuc=",
"ref": "sexp-parser",
"rev": "b0a7f96d6569d16b0d27c2f9477d94e5ee39df66",
"revCount": 62,
"type": "git",
"url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
},
"original": {
"ref": "sexp-parser",
"rev": "b0a7f96d6569d16b0d27c2f9477d94e5ee39df66",
"type": "git",
"url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
}
},
"haskell-flake-utils": { "haskell-flake-utils": {
"inputs": { "inputs": {
"flake-utils": "flake-utils" "flake-utils": "flake-utils"
}, },
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_2": {
"inputs": {
"flake-utils": "flake-utils_2"
},
"locked": { "locked": {
"lastModified": 1672412555, "lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=", "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
@ -35,23 +89,41 @@
}, },
"nixpkgs": { "nixpkgs": {
"locked": { "locked": {
"lastModified": 1697354318, "lastModified": 1707451808,
"narHash": "sha256-djcTObM8B9viipkxD977YBtzKcPwbMZFWLbNThZnkuY=", "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS", "owner": "NixOS",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "2c8de852d2e079b0827e0e64a8f023d79f1ef814", "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github" "type": "github"
}, },
"original": { "original": {
"owner": "NixOS", "owner": "NixOS",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github" "type": "github"
} }
}, },
"root": { "root": {
"inputs": { "inputs": {
"haskell-flake-utils": "haskell-flake-utils", "fuzzy": "fuzzy",
"nixpkgs": "nixpkgs" "haskell-flake-utils": "haskell-flake-utils_2",
"nixpkgs": "nixpkgs_2"
} }
} }
}, },

20
flake.nix
View File

@ -2,15 +2,26 @@
description = "suckless-cong: sexp based configs"; description = "suckless-cong: sexp based configs";
inputs = { inputs = {
nixpkgs.url = "github:NixOS/nixpkgs"; nixpkgs.url = "github:NixOS/nixpkgs?rev=442d407992384ed9c0e6d352de75b69079904e4e";
haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils"; 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/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=b0a7f96d6569d16b0d27c2f9477d94e5ee39df66";
}; };
outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: outputs = { self, fuzzy, nixpkgs, haskell-flake-utils, ... }@inputs:
haskell-flake-utils.lib.simpleCabal2flake { haskell-flake-utils.lib.simpleCabal2flake {
inherit self nixpkgs; inherit self nixpkgs;
# systems = [ "x86_64-linux" ]; # systems = [ "x86_64-linux" ];
# wtf = import fetcher-flake.out.outPath;
# project-b = import fuzzy.out.outPath;
name = "suckless-conf"; name = "suckless-conf";
## Optional parameters follow ## Optional parameters follow
@ -41,7 +52,10 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
# }; # };
# Maps to the devShell output. Pass in a shell.nix file or function # Maps to the devShell output. Pass in a shell.nix file or function
# shell = ./shell.nix
haskellFlakes = with inputs; [
fuzzy
];
# Additional build intputs of the default shell # Additional build intputs of the default shell
shellExtBuildInputs = {pkgs}: with pkgs; [ shellExtBuildInputs = {pkgs}: with pkgs; [

51
lib/Data/Config/Suckless/KeyValue.hs
View File

@ -4,7 +4,6 @@
module Data.Config.Suckless.KeyValue where module Data.Config.Suckless.KeyValue where
import Data.Config.Suckless.Syntax import Data.Config.Suckless.Syntax
import Data.Config.Suckless.Parse
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Set qualified as Set import Data.Set qualified as Set
@ -14,11 +13,12 @@ import Data.Scientific
import Data.Aeson import Data.Aeson
import Prettyprinter import Prettyprinter
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Identity
import Safe import Safe
type C = MegaParsec import Debug.Trace
class Monad m => HasCfgKey a b m where class HasCfgKey a b where
-- type family CfgValue a :: Type -- type family CfgValue a :: Type
key :: Id key :: Id
@ -31,82 +31,81 @@ class Monad m => HasConf m where
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
pattern Key n ns <- SymbolVal n : ns pattern Key n ns <- SymbolVal n : ns
instance {-# OVERLAPPABLE #-} (Monad m) => HasConf (ReaderT [Syntax C] m) where
instance {-# OVERLAPPABLE #-} Monad m => HasConf (ReaderT [Syntax C] m) where
getConf = ask getConf = ask
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer) m) => HasCfgValue a (Maybe Integer) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer)) => HasCfgValue a (Maybe Integer) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf
where where
val syn = [ e val syn = [ e
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer) @m | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Int) m) => HasCfgValue a (Maybe Int) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Int)) => HasCfgValue a (Maybe Int) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf @m
where where
val syn = [ fromIntegral e val syn = [ fromIntegral e
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Int) @m | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Int)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific) m) => HasCfgValue a (Maybe Scientific) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific)) => HasCfgValue a (Maybe Scientific) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf
where where
val syn = [ e val syn = [ e
| ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific) @m | ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool) m) => HasCfgValue a (Maybe Bool) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool)) => HasCfgValue a (Maybe Bool) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf
where where
val syn = [ e val syn = [ e
| ListVal (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool) @m | ListVal (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value) m) => HasCfgValue a (Maybe Value) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value)) => HasCfgValue a (Maybe Value) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf
where where
val syn = [ toJSON v val syn = [ toJSON v
| ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value) @m | ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, IsString b, HasCfgKey a (Maybe b) m) => HasCfgValue a (Maybe b) m where instance {-# OVERLAPPABLE #-} (HasConf m, IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) m where
cfgValue = lastMay . val <$> getConf cfgValue = lastMay . val <$> getConf
where where
val syn = [ fromString (show $ pretty e) val syn = [ fromString (show $ pretty e)
| ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b) @m | ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer) m) => HasCfgValue a (Set Integer) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer)) => HasCfgValue a (Set Integer) m where
cfgValue = Set.fromList . val <$> getConf cfgValue = Set.fromList . val <$> getConf
where where
val syn = [ e val syn = [ e
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer) @m | ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific) m) => HasCfgValue a (Set Scientific) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific)) => HasCfgValue a (Set Scientific) m where
cfgValue = Set.fromList . val <$> getConf cfgValue = Set.fromList . val <$> getConf
where where
val syn = [ e val syn = [ e
| ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific) @m | ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value) m) => HasCfgValue a (Set Value) m where instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value)) => HasCfgValue a (Set Value) m where
cfgValue = Set.fromList . val <$> getConf cfgValue = Set.fromList . val <$> getConf
where where
val syn = [ toJSON v val syn = [ toJSON v
| ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value) @m | ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value)
] ]
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b) m) => HasCfgValue a (Set b) m where instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b)) => HasCfgValue a (Set b) m where
cfgValue = Set.fromList . val <$> getConf cfgValue = Set.fromList . val <$> getConf
where where
val syn = [ fromString (show $ pretty e) val syn = [ fromString (show $ pretty e)
| ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Set b) @m | ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Set b)
] ]

4
lib/Data/Config/Suckless/Parse.hs
View File

@ -1,8 +1,8 @@
module Data.Config.Suckless.Parse module Data.Config.Suckless.Parse
( module Data.Config.Suckless.Parse.Megaparsec ( module Data.Config.Suckless.Parse.Fuzzy
) where ) where
import Data.Config.Suckless.Parse.Megaparsec import Data.Config.Suckless.Parse.Fuzzy

39
lib/Data/Config/Suckless/Parse/Fuzzy.hs Normal file
View File

@ -0,0 +1,39 @@
module Data.Config.Suckless.Parse.Fuzzy
( parseTop
, parseSyntax
-- , C
) 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
import Control.Monad.Except
import Control.Monad.Identity
import Data.Coerce
parseTop :: Text -> Either SExpParseError [Syntax C]
parseTop what = runIdentity (runExceptT (P.parseTop what)) <&> fmap toSyntax
parseSyntax :: Text -> Either SExpParseError (Syntax C)
parseSyntax txt = runIdentity (runExceptT (P.parseSexp 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)

226
lib/Data/Config/Suckless/Parse/Megaparsec.hs
View File

@ -1,226 +0,0 @@
{-# Language ConstraintKinds #-}
{-# Language UndecidableInstances #-}
module Data.Config.Suckless.Parse.Megaparsec
( parseSyntax
, parseTop
, MegaParsec
, MegaContext
)
where
import Data.Config.Suckless.Syntax
import Control.Applicative()
import Data.Text qualified as Text
import Control.Monad
import Data.Functor
import Text.Megaparsec
import Text.Megaparsec.Char (hspace1,space1,char,letterChar,digitChar,eol,string)
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Megaparsec.Char.Lexer ( signed )
import Data.String(IsString(..))
import GHC.Generics
import Data.Data
import Safe
import Data.Scientific
data MegaParsec =
MegaParsec
deriving (Data,Typeable,Generic)
newtype instance Context MegaParsec =
MegaContext (Maybe Int)
deriving (Eq,Ord,Generic)
instance IsContext MegaParsec where
noContext = MegaContext Nothing
type MegaContext = Context MegaParsec
type MegaConstraints c = ( c ~ MegaParsec, IsContext c )
type Parser r = Parsec () [Char] r
type ParseFail = ParseErrorBundle [Char] ()
deriving instance Eq (Context MegaParsec) => Eq (Syntax MegaParsec)
deriving instance Ord (Context MegaParsec) => Ord (Syntax MegaParsec)
sc :: Parser ()
sc = do
L.space space1 lineComment empty
where
lineComment = L.skipLineComment ";"
scTop :: Parser ()
scTop = do
L.space hspace1 lineComment empty
where
lineComment = L.skipLineComment ";"
dquot :: Parser Char
dquot = char '"'
-- FIXME: position!
stringLit :: forall c . MegaConstraints c
=> Parser () -> Parser (Syntax c)
stringLit sp = L.lexeme sp $ do
co <- MegaContext . Just <$> getOffset
Literal co . LitStr <$> str
where
str = do
s <- dquot >> manyTill L.charLiteral dquot
pure $ Text.pack s -- (mconcat [ showLitChar c "" | c <- s ])
numLit :: forall c . MegaConstraints c
=> Parser () -> Parser (Syntax c)
numLit sp = L.lexeme sp $ do
co <- MegaContext . Just <$> getOffset
s <- try (char '-' >> pure True) <|> pure False
base <- choice [ string "0x" >> pure 16
, string "0o" >> pure 8
, string "0b" >> pure 2
, pure (10 :: Int)
]
val <- case base of
16 -> LitInt . sign s <$> L.hexadecimal
8 -> LitInt . sign s <$> L.octal
2 -> LitInt . sign s <$> L.binary
10 -> do
ns <- many (digitChar <|> oneOf ['.', 'e', '-'])
let v = (LitInt . sign s <$> readMay @Integer ns)
<|> (LitScientific . sign s <$> readMay @Scientific ns)
case v of
Just x -> pure x
Nothing -> fail "not a numeric literal"
_ -> fail "not a numeric literal"
pure $ Literal co val
where
sign :: forall a . Num a => Bool -> a -> a
sign x = if x then negate else id
symbolChars :: [Char]
symbolChars = "-!$%&|*+/:<=>?@^_~#.'"
symbolChar :: Parser Char
symbolChar = oneOf symbolChars
symbolCharNoMinus :: Parser Char
symbolCharNoMinus = oneOf symbolChars'
where
symbolChars' = dropWhile (`elem` "-") symbolChars
-- FIXME: position!
symbol :: forall c . MegaConstraints c
=> Parser () -> Parser (Syntax c)
symbol sp = L.lexeme sp $ do
co <- MegaContext . Just <$> getOffset
h <- letterChar <|> symbolCharNoMinus
-- FIXME: dont-start-symbol-with-minus
t <- many (letterChar <|> digitChar <|> symbolChar)
case h:t of
"#t" -> pure $ Literal co (mkLit True)
"#f" -> pure $ Literal co (mkLit False)
other -> pure $ Symbol co (fromString other)
skipChar :: Char -> Parser ()
skipChar c = void (char c)
oParen :: Parser ()
oParen = skipChar '('
cParen :: Parser ()
cParen = skipChar ')'
oBrace :: Parser ()
oBrace = skipChar '{'
cBrace :: Parser ()
cBrace = skipChar '}'
oBracket :: Parser ()
oBracket= skipChar '['
cBracket :: Parser ()
cBracket = skipChar ']'
someEnclosedBy :: Parser ()
-> Parser a
-> Parser ()
-> Parser [a]
someEnclosedBy o i c = do
between o c (many (sc >> i)) -- <|> parseError (error (show ("WTF!", ctx))) -- (ParseError (ListParseError ctx))
list :: forall c . MegaConstraints c
=> Parser() -> Parser (Syntax c)
list sp = L.lexeme sp $ do
co <- MegaContext . Just <$> getOffset
List co <$> choice [ someEnclosedBy oParen (syntax sp) cParen
, someEnclosedBy oBrace (syntax sp) cBrace
, someEnclosedBy oBracket (syntax sp) cBracket
]
syntax :: forall c . MegaConstraints c
=> Parser () -> Parser (Syntax c)
syntax sp = choice [ symbol sp
, numLit sp
, stringLit sp
, list sp
]
merely :: Parser a -> Parser a
merely f = do
sc
r <- f
sc
eof
pure r
parseSyntax :: forall c . MegaConstraints c
=> String -> Either ParseFail (Syntax c)
parseSyntax = parse (merely (syntax sc)) "input"
top :: forall c . MegaConstraints c => Parser [Syntax c]
top = do
sc
many $ do
t <- topStmt
sc
pure t
topTerm :: forall c . MegaConstraints c => Parser (Syntax c)
topTerm = do
co <- MegaContext . Just <$> getOffset
s0 <- symbol scTop
ss <- many (syntax scTop)
void eol <|> eof
pure $ List co (s0:ss)
topStmt :: forall c . MegaConstraints c => Parser (Syntax c)
topStmt = topTerm <|> syntax sc
parseTop :: forall c . MegaConstraints c
=> String -> Either ParseFail [Syntax c]
parseTop = parse top "input"
deriving instance Data (Context MegaParsec)

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

@ -2,12 +2,14 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Config.Suckless.Syntax module Data.Config.Suckless.Syntax
( Syntax(..) ( Syntax(..)
, Id(..) , Id(..)
, Literal(..) , Literal(..)
, Context , HasContext
, HasContext(..) , C(..)
, Context(..)
, IsContext(..) , IsContext(..)
, IsLiteral(..) , IsLiteral(..)
, pattern SymbolVal , pattern SymbolVal
@ -24,8 +26,10 @@ import Data.Kind
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
import Data.Scientific import Data.Scientific
import GHC.Generics import GHC.Generics (Generic(..))
import Data.Maybe import Data.Maybe
-- import GHC.Generics( Fixity(..) )
-- import Data.Data as Data
import Data.Aeson import Data.Aeson
import Data.Aeson.Key import Data.Aeson.Key
import Data.Aeson.KeyMap qualified as Aeson import Data.Aeson.KeyMap qualified as Aeson
@ -38,19 +42,19 @@ pattern SymbolVal :: Id -> Syntax c
pattern SymbolVal v <- Symbol _ v pattern SymbolVal v <- Symbol _ v
-- pattern LitVal :: forall {c}. Id -> Li -- pattern LitVal :: forall {c}. Id -> Li
pattern LitIntVal :: forall {c}. Integer -> Syntax c pattern LitIntVal :: Integer -> Syntax c
pattern LitIntVal v <- Literal _ (LitInt v) pattern LitIntVal v <- Literal _ (LitInt v)
pattern LitScientificVal :: forall {c}. Scientific -> Syntax c pattern LitScientificVal :: Scientific -> Syntax c
pattern LitScientificVal v <- Literal _ (LitScientific v) pattern LitScientificVal v <- Literal _ (LitScientific v)
pattern LitStrVal :: forall {c}. Text -> Syntax c pattern LitStrVal :: Text -> Syntax c
pattern LitStrVal v <- Literal _ (LitStr v) pattern LitStrVal v <- Literal _ (LitStr v)
pattern LitBoolVal :: forall {c}. Bool -> Syntax c pattern LitBoolVal :: Bool -> Syntax c
pattern LitBoolVal v <- Literal _ (LitBool v) pattern LitBoolVal v <- Literal _ (LitBool v)
pattern ListVal :: forall {c}. [Syntax c] -> Syntax c pattern ListVal :: [Syntax c] -> Syntax c
pattern ListVal v <- List _ v pattern ListVal v <- List _ v
@ -65,8 +69,6 @@ instance IsContext () where
noContext = EmptyContext noContext = EmptyContext
class HasContext c a where class HasContext c a where
setContext :: Context c -> a -> a
getContext :: a -> Context c
class IsLiteral a where class IsLiteral a where
mkLit :: a -> Literal mkLit :: a -> Literal
@ -92,6 +94,21 @@ instance IsLiteral Bool where
instance IsLiteral Integer where instance IsLiteral Integer where
mkLit = LitInt 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 data Syntax c
= List (Context c) [Syntax c] = List (Context c) [Syntax c]
| Symbol (Context c) Id | Symbol (Context c) Id
@ -99,17 +116,14 @@ data Syntax c
deriving stock (Generic) deriving stock (Generic)
instance Eq (Syntax c) where
(==) (Literal _ a) (Literal _ b) = a == b
(==) (Symbol _ a) (Symbol _ b) = a == b
(==) (List _ a) (List _ b) = a == b
(==) _ _ = False
instance HasContext c (Syntax c) where deriving instance (Data (Context ())) => Data (Syntax ())
setContext c1 = \case -- deriving instance (Data (Context ())) => Data (Syntax ())
List _ v -> List c1 v
Symbol _ v -> Symbol c1 v
Literal _ v -> Literal c1 v
getContext = \case
List x _ -> x
Symbol x _ -> x
Literal x _ -> x
instance Pretty (Syntax c) where instance Pretty (Syntax c) where
pretty (Literal _ ast) = pretty ast pretty (Literal _ ast) = pretty ast
@ -127,13 +141,6 @@ instance Pretty Literal where
| otherwise -> "#f" | otherwise -> "#f"
deriving instance ( Data c
, Data (Context c)
, Typeable c
) => Data (Syntax c)
instance ToJSON Literal where instance ToJSON Literal where
toJSON (LitStr s) = String s toJSON (LitStr s) = String s
toJSON (LitInt i) = Number (fromInteger i) toJSON (LitInt i) = Number (fromInteger i)
@ -157,8 +164,7 @@ instance ToJSON (Syntax c) where
pairToKeyValue _ = Nothing pairToKeyValue _ = Nothing
instance IsContext c => FromJSON (Syntax c) where
instance FromJSON (Syntax ()) where
parseJSON (String t) = pure $ Literal noContext (LitStr t) parseJSON (String t) = pure $ Literal noContext (LitStr t)
parseJSON (Number n) parseJSON (Number n)
| isInteger n = pure $ Literal noContext (LitInt (floor n)) | isInteger n = pure $ Literal noContext (LitInt (floor n))

13
suckless-conf.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: suckless-conf name: suckless-conf
version: 0.1.0.0 version: 0.1.2.0
-- synopsis: -- synopsis:
-- description: -- description:
license: BSD-3-Clause license: BSD-3-Clause
@ -53,6 +53,7 @@ common shared-properties
, TupleSections , TupleSections
, TypeApplications , TypeApplications
, TypeFamilies , TypeFamilies
, ImportQualifiedPost
@ -67,14 +68,13 @@ library
other-modules: other-modules:
Data.Config.Suckless.Types Data.Config.Suckless.Types
, Data.Config.Suckless.Parse.Megaparsec , Data.Config.Suckless.Parse.Fuzzy
-- other-extensions: -- other-extensions:
build-depends: base >=4.15.1.0 build-depends: base
, aeson , aeson
, bytestring , bytestring
, containers , containers
, megaparsec
, mtl , mtl
, prettyprinter , prettyprinter
, safe , safe
@ -82,11 +82,13 @@ library
, text , text
, vector , vector
, unordered-containers , unordered-containers
, fuzzy-parse >= 0.1.3.0
hs-source-dirs: lib hs-source-dirs: lib
default-language: Haskell2010 default-language: Haskell2010
test-suite spec test-suite spec
import: shared-properties
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules:
@ -107,10 +109,13 @@ test-suite spec
, aeson , aeson
, scientific , scientific
, suckless-conf , suckless-conf
, fuzzy-parse >= 0.1.3.0
, containers , containers
, mtl , mtl
, text
, prettyprinter , prettyprinter
, interpolatedstring-perl6 , interpolatedstring-perl6
, tasty-hunit
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:

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

@ -1,6 +1,11 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Data.Config.Suckless.AesonSpec (spec) where module Data.Config.Suckless.AesonSpec (spec) where
@ -10,16 +15,20 @@ import Data.Config.Suckless.Syntax
import Data.Functor import Data.Functor
import Data.Function import Data.Function
import Data.Scientific import Data.Scientific
import Data.Text (Text)
import Data.Text.IO qualified as Text
import GHC.Generics hiding (C) import GHC.Generics hiding (C)
import Text.InterpolatedString.Perl6 (qc,q) import Text.InterpolatedString.Perl6 (qc,q)
import Data.Aeson import Data.Aeson
import Data.Maybe import Data.Maybe
import Control.Monad.Reader
import Test.Hspec import Test.Hspec
import Test.Tasty.HUnit
import Prettyprinter import Prettyprinter
readConfig :: String -> IO [Syntax C] readConfig :: Text -> IO [Syntax C]
readConfig s = do readConfig s = do
pure $ parseTop s & either mempty id pure $ parseTop s & either mempty id
-- print $ pretty f -- print $ pretty f
@ -36,6 +45,15 @@ data SomeData =
instance ToJSON SomeData instance ToJSON SomeData
instance FromJSON 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 :: Spec
spec = do spec = do
describe "toJSON" $ do describe "toJSON" $ do
@ -50,9 +68,9 @@ spec = do
it "reads bool" $ do it "reads bool" $ do
t <- readConfig [qc|#t|] <&> toJSON . head t <- readConfig [qc|#t|] <&> toJSON . head
t `shouldBe` toJSON [Bool True] t `shouldBe` toJSON (Bool True)
f <- readConfig [qc|#f|] <&> toJSON . head f <- readConfig [qc|#f|] <&> toJSON . head
f `shouldBe` toJSON [Bool False] f `shouldBe` toJSON (Bool False)
it "reads string" $ do it "reads string" $ do
s <- readConfig [qc|"somestring"|] <&> toJSON s <- readConfig [qc|"somestring"|] <&> toJSON
@ -110,4 +128,85 @@ spec = do
print someObject print someObject
someObject `shouldBe` Success some 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)

39
test/Data/Config/Suckless/KeyValueSpec.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Data.Config.Suckless.KeyValueSpec (spec) where module Data.Config.Suckless.KeyValueSpec (spec) where
@ -12,13 +14,16 @@ import Data.Config.Suckless.Parse
import Data.Config.Suckless.Syntax import Data.Config.Suckless.Syntax
import Data.Functor import Data.Functor
import Data.Scientific import Data.Scientific
import Data.Text.IO qualified as Text
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Prettyprinter import Prettyprinter
import Data.Aeson import Data.Aeson
import Text.InterpolatedString.Perl6 (qc,q) import Text.InterpolatedString.Perl6 (qc,q)
import Control.Monad.Identity
import Test.Hspec import Test.Hspec
data FirstKey data FirstKey
data SecondKey data SecondKey
@ -41,52 +46,52 @@ data Sci5
data O1 data O1
data O2 data O2
instance Monad m => HasCfgKey FirstKey (Maybe String) m where instance HasCfgKey FirstKey (Maybe String) where
key = "foo" key = "foo"
instance Monad m => HasCfgKey SecondKey (Set String) m where instance HasCfgKey SecondKey (Set String) where
key = "bar" key = "bar"
instance Monad m => HasCfgKey ThirdKey (Maybe String) m where instance HasCfgKey ThirdKey (Maybe String) where
key = "baz" key = "baz"
instance Monad m => HasCfgKey Int1 b m where instance HasCfgKey Int1 b where
key = "int1" key = "int1"
instance Monad m => HasCfgKey Int2 b m where instance HasCfgKey Int2 b where
key = "int2" key = "int2"
instance Monad m => HasCfgKey Int3 b m where instance HasCfgKey Int3 b where
key = "int3" key = "int3"
instance Monad m => HasCfgKey Int4 b m where instance HasCfgKey Int4 b where
key = "int4" key = "int4"
instance Monad m => HasCfgKey Int5 b m where instance HasCfgKey Int5 b where
key = "int5" key = "int5"
instance Monad m => HasCfgKey Int6 b m where instance HasCfgKey Int6 b where
key = "int6" key = "int6"
instance Monad m => HasCfgKey Sci1 b m where instance HasCfgKey Sci1 b where
key = "sci1" key = "sci1"
instance Monad m => HasCfgKey Sci2 b m where instance HasCfgKey Sci2 b where
key = "sci2" key = "sci2"
instance Monad m => HasCfgKey Sci3 b m where instance HasCfgKey Sci3 b where
key = "sci3" key = "sci3"
instance Monad m => HasCfgKey Sci4 b m where instance HasCfgKey Sci4 b where
key = "sci4" key = "sci4"
instance Monad m => HasCfgKey Sci5 b m where instance HasCfgKey Sci5 b where
key = "sci5" key = "sci5"
instance Monad m => HasCfgKey O1 b m where instance HasCfgKey O1 b where
key = "some-object" key = "some-object"
instance Monad m => HasCfgKey O2 b m where instance HasCfgKey O2 b where
key = "another-object" key = "another-object"
instance HasConf IO where instance HasConf IO where
@ -95,7 +100,7 @@ instance HasConf IO where
readConfig :: IO [Syntax C] readConfig :: IO [Syntax C]
readConfig = do readConfig = do
let configFilePath = "t/key-value-test-config" let configFilePath = "t/key-value-test-config"
f <- readFile configFilePath <&> parseTop <&> either mempty id f <- Text.readFile configFilePath <&> parseTop <&> either mempty id
print $ pretty f print $ pretty f
pure f pure f