0.1.2.0
This commit is contained in:
Dmitry Zuikov
parent
8cfc1272bb
commit
0c5c235ed2
82
flake.lock
82
flake.lock
|
|
@ -15,10 +15,64 @@
|
|||
"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": {
|
||||
"inputs": {
|
||||
"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": {
|
||||
"lastModified": 1672412555,
|
||||
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
|
||||
|
|
@ -35,23 +89,41 @@
|
|||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1697354318,
|
||||
"narHash": "sha256-djcTObM8B9viipkxD977YBtzKcPwbMZFWLbNThZnkuY=",
|
||||
"lastModified": 1707451808,
|
||||
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "2c8de852d2e079b0827e0e64a8f023d79f1ef814",
|
||||
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"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"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"haskell-flake-utils": "haskell-flake-utils",
|
||||
"nixpkgs": "nixpkgs"
|
||||
"fuzzy": "fuzzy",
|
||||
"haskell-flake-utils": "haskell-flake-utils_2",
|
||||
"nixpkgs": "nixpkgs_2"
|
||||
}
|
||||
}
|
||||
},
|
||||
|
|
|
|||
20
flake.nix
20
flake.nix
|
|
@ -2,15 +2,26 @@
|
|||
description = "suckless-cong: sexp based configs";
|
||||
|
||||
inputs = {
|
||||
nixpkgs.url = "github:NixOS/nixpkgs";
|
||||
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/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 {
|
||||
|
||||
inherit self nixpkgs;
|
||||
# systems = [ "x86_64-linux" ];
|
||||
|
||||
# wtf = import fetcher-flake.out.outPath;
|
||||
# project-b = import fuzzy.out.outPath;
|
||||
|
||||
name = "suckless-conf";
|
||||
|
||||
## 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
|
||||
# shell = ./shell.nix
|
||||
|
||||
haskellFlakes = with inputs; [
|
||||
fuzzy
|
||||
];
|
||||
|
||||
# Additional build intputs of the default shell
|
||||
shellExtBuildInputs = {pkgs}: with pkgs; [
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@
|
|||
module Data.Config.Suckless.KeyValue where
|
||||
|
||||
import Data.Config.Suckless.Syntax
|
||||
import Data.Config.Suckless.Parse
|
||||
|
||||
import Data.String (IsString(..))
|
||||
import Data.Set qualified as Set
|
||||
|
|
@ -14,11 +13,12 @@ import Data.Scientific
|
|||
import Data.Aeson
|
||||
import Prettyprinter
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Identity
|
||||
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
|
||||
key :: Id
|
||||
|
||||
|
|
@ -31,82 +31,81 @@ class Monad m => HasConf m where
|
|||
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
|
||||
instance {-# OVERLAPPABLE #-} (Monad m) => HasConf (ReaderT [Syntax C] m) where
|
||||
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
|
||||
where
|
||||
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
|
||||
cfgValue = lastMay . val <$> getConf
|
||||
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) @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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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
|
||||
where
|
||||
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)
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
module Data.Config.Suckless.Parse
|
||||
( module Data.Config.Suckless.Parse.Megaparsec
|
||||
( module Data.Config.Suckless.Parse.Fuzzy
|
||||
) where
|
||||
|
||||
import Data.Config.Suckless.Parse.Megaparsec
|
||||
import Data.Config.Suckless.Parse.Fuzzy
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
@ -2,12 +2,14 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Data.Config.Suckless.Syntax
|
||||
( Syntax(..)
|
||||
, Id(..)
|
||||
, Literal(..)
|
||||
, Context
|
||||
, HasContext(..)
|
||||
, HasContext
|
||||
, C(..)
|
||||
, Context(..)
|
||||
, IsContext(..)
|
||||
, IsLiteral(..)
|
||||
, pattern SymbolVal
|
||||
|
|
@ -24,8 +26,10 @@ import Data.Kind
|
|||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Scientific
|
||||
import GHC.Generics
|
||||
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
|
||||
|
|
@ -38,19 +42,19 @@ pattern SymbolVal :: Id -> Syntax c
|
|||
pattern SymbolVal v <- Symbol _ v
|
||||
|
||||
-- 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 LitScientificVal :: forall {c}. Scientific -> Syntax c
|
||||
pattern LitScientificVal :: Scientific -> Syntax c
|
||||
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 LitBoolVal :: forall {c}. Bool -> Syntax c
|
||||
pattern LitBoolVal :: Bool -> Syntax c
|
||||
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
|
||||
|
||||
|
||||
|
|
@ -65,8 +69,6 @@ instance IsContext () where
|
|||
noContext = EmptyContext
|
||||
|
||||
class HasContext c a where
|
||||
setContext :: Context c -> a -> a
|
||||
getContext :: a -> Context c
|
||||
|
||||
class IsLiteral a where
|
||||
mkLit :: a -> Literal
|
||||
|
|
@ -92,6 +94,21 @@ instance IsLiteral Bool where
|
|||
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
|
||||
|
|
@ -99,17 +116,14 @@ data Syntax c
|
|||
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
|
||||
setContext c1 = \case
|
||||
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
|
||||
deriving instance (Data (Context ())) => Data (Syntax ())
|
||||
-- deriving instance (Data (Context ())) => Data (Syntax ())
|
||||
|
||||
instance Pretty (Syntax c) where
|
||||
pretty (Literal _ ast) = pretty ast
|
||||
|
|
@ -127,13 +141,6 @@ instance Pretty Literal where
|
|||
| otherwise -> "#f"
|
||||
|
||||
|
||||
deriving instance ( Data c
|
||||
, Data (Context c)
|
||||
, Typeable c
|
||||
) => Data (Syntax c)
|
||||
|
||||
|
||||
|
||||
instance ToJSON Literal where
|
||||
toJSON (LitStr s) = String s
|
||||
toJSON (LitInt i) = Number (fromInteger i)
|
||||
|
|
@ -157,8 +164,7 @@ instance ToJSON (Syntax c) where
|
|||
pairToKeyValue _ = Nothing
|
||||
|
||||
|
||||
|
||||
instance FromJSON (Syntax ()) where
|
||||
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))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 3.0
|
||||
name: suckless-conf
|
||||
version: 0.1.0.0
|
||||
version: 0.1.2.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
|
|
@ -53,6 +53,7 @@ common shared-properties
|
|||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeFamilies
|
||||
, ImportQualifiedPost
|
||||
|
||||
|
||||
|
||||
|
|
@ -67,14 +68,13 @@ library
|
|||
|
||||
other-modules:
|
||||
Data.Config.Suckless.Types
|
||||
, Data.Config.Suckless.Parse.Megaparsec
|
||||
, Data.Config.Suckless.Parse.Fuzzy
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.15.1.0
|
||||
build-depends: base
|
||||
, aeson
|
||||
, bytestring
|
||||
, containers
|
||||
, megaparsec
|
||||
, mtl
|
||||
, prettyprinter
|
||||
, safe
|
||||
|
|
@ -82,11 +82,13 @@ library
|
|||
, text
|
||||
, vector
|
||||
, unordered-containers
|
||||
, fuzzy-parse >= 0.1.3.0
|
||||
|
||||
hs-source-dirs: lib
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
import: shared-properties
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
|
|
@ -107,10 +109,13 @@ test-suite spec
|
|||
, aeson
|
||||
, scientific
|
||||
, suckless-conf
|
||||
, fuzzy-parse >= 0.1.3.0
|
||||
, containers
|
||||
, mtl
|
||||
, text
|
||||
, prettyprinter
|
||||
, interpolatedstring-perl6
|
||||
, tasty-hunit
|
||||
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
|
|
|
|||
|
|
@ -1,6 +1,11 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Data.Config.Suckless.AesonSpec (spec) where
|
||||
|
||||
|
|
@ -10,16 +15,20 @@ 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 :: String -> IO [Syntax C]
|
||||
readConfig :: Text -> IO [Syntax C]
|
||||
readConfig s = do
|
||||
pure $ parseTop s & either mempty id
|
||||
-- print $ pretty f
|
||||
|
|
@ -36,6 +45,15 @@ data SomeData =
|
|||
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
|
||||
|
|
@ -50,9 +68,9 @@ spec = do
|
|||
|
||||
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
|
||||
|
|
@ -110,4 +128,85 @@ spec = do
|
|||
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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Data.Config.Suckless.KeyValueSpec (spec) where
|
||||
|
|
@ -12,13 +14,16 @@ 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 Control.Monad.Identity
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
data FirstKey
|
||||
|
||||
data SecondKey
|
||||
|
|
@ -41,52 +46,52 @@ data Sci5
|
|||
data O1
|
||||
data O2
|
||||
|
||||
instance Monad m => HasCfgKey FirstKey (Maybe String) m where
|
||||
instance HasCfgKey FirstKey (Maybe String) where
|
||||
key = "foo"
|
||||
|
||||
instance Monad m => HasCfgKey SecondKey (Set String) m where
|
||||
instance HasCfgKey SecondKey (Set String) where
|
||||
key = "bar"
|
||||
|
||||
instance Monad m => HasCfgKey ThirdKey (Maybe String) m where
|
||||
instance HasCfgKey ThirdKey (Maybe String) where
|
||||
key = "baz"
|
||||
|
||||
instance Monad m => HasCfgKey Int1 b m where
|
||||
instance HasCfgKey Int1 b where
|
||||
key = "int1"
|
||||
|
||||
instance Monad m => HasCfgKey Int2 b m where
|
||||
instance HasCfgKey Int2 b where
|
||||
key = "int2"
|
||||
|
||||
instance Monad m => HasCfgKey Int3 b m where
|
||||
instance HasCfgKey Int3 b where
|
||||
key = "int3"
|
||||
|
||||
instance Monad m => HasCfgKey Int4 b m where
|
||||
instance HasCfgKey Int4 b where
|
||||
key = "int4"
|
||||
|
||||
instance Monad m => HasCfgKey Int5 b m where
|
||||
instance HasCfgKey Int5 b where
|
||||
key = "int5"
|
||||
|
||||
instance Monad m => HasCfgKey Int6 b m where
|
||||
instance HasCfgKey Int6 b where
|
||||
key = "int6"
|
||||
|
||||
instance Monad m => HasCfgKey Sci1 b m where
|
||||
instance HasCfgKey Sci1 b where
|
||||
key = "sci1"
|
||||
|
||||
instance Monad m => HasCfgKey Sci2 b m where
|
||||
instance HasCfgKey Sci2 b where
|
||||
key = "sci2"
|
||||
|
||||
instance Monad m => HasCfgKey Sci3 b m where
|
||||
instance HasCfgKey Sci3 b where
|
||||
key = "sci3"
|
||||
|
||||
instance Monad m => HasCfgKey Sci4 b m where
|
||||
instance HasCfgKey Sci4 b where
|
||||
key = "sci4"
|
||||
|
||||
instance Monad m => HasCfgKey Sci5 b m where
|
||||
instance HasCfgKey Sci5 b where
|
||||
key = "sci5"
|
||||
|
||||
instance Monad m => HasCfgKey O1 b m where
|
||||
instance HasCfgKey O1 b where
|
||||
key = "some-object"
|
||||
|
||||
instance Monad m => HasCfgKey O2 b m where
|
||||
instance HasCfgKey O2 b where
|
||||
key = "another-object"
|
||||
|
||||
instance HasConf IO where
|
||||
|
|
@ -95,7 +100,7 @@ instance HasConf IO where
|
|||
readConfig :: IO [Syntax C]
|
||||
readConfig = do
|
||||
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
|
||||
pure f
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue