From 0c5c235ed2bc6218d24a50aded412876a8fabb65 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 16 May 2024 14:59:26 +0300 Subject: [PATCH] 0.1.2.0 --- flake.lock | 82 ++++++- flake.nix | 20 +- lib/Data/Config/Suckless/KeyValue.hs | 51 ++--- lib/Data/Config/Suckless/Parse.hs | 4 +- lib/Data/Config/Suckless/Parse/Fuzzy.hs | 39 ++++ lib/Data/Config/Suckless/Parse/Megaparsec.hs | 226 ------------------- lib/Data/Config/Suckless/Syntax.hs | 64 +++--- suckless-conf.cabal | 13 +- test/Data/Config/Suckless/AesonSpec.hs | 105 ++++++++- test/Data/Config/Suckless/KeyValueSpec.hs | 39 ++-- 10 files changed, 328 insertions(+), 315 deletions(-) create mode 100644 lib/Data/Config/Suckless/Parse/Fuzzy.hs delete mode 100644 lib/Data/Config/Suckless/Parse/Megaparsec.hs diff --git a/flake.lock b/flake.lock index 6db2eca..6cb875b 100644 --- a/flake.lock +++ b/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" } } }, diff --git a/flake.nix b/flake.nix index 6f25638..f77350c 100644 --- a/flake.nix +++ b/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; [ diff --git a/lib/Data/Config/Suckless/KeyValue.hs b/lib/Data/Config/Suckless/KeyValue.hs index c27aacd..447e055 100644 --- a/lib/Data/Config/Suckless/KeyValue.hs +++ b/lib/Data/Config/Suckless/KeyValue.hs @@ -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) ] diff --git a/lib/Data/Config/Suckless/Parse.hs b/lib/Data/Config/Suckless/Parse.hs index 3666621..6b93252 100644 --- a/lib/Data/Config/Suckless/Parse.hs +++ b/lib/Data/Config/Suckless/Parse.hs @@ -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 diff --git a/lib/Data/Config/Suckless/Parse/Fuzzy.hs b/lib/Data/Config/Suckless/Parse/Fuzzy.hs new file mode 100644 index 0000000..d57d975 --- /dev/null +++ b/lib/Data/Config/Suckless/Parse/Fuzzy.hs @@ -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) + + + diff --git a/lib/Data/Config/Suckless/Parse/Megaparsec.hs b/lib/Data/Config/Suckless/Parse/Megaparsec.hs deleted file mode 100644 index 304dce2..0000000 --- a/lib/Data/Config/Suckless/Parse/Megaparsec.hs +++ /dev/null @@ -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) - - - diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs index 3b1fa91..3c30630 100644 --- a/lib/Data/Config/Suckless/Syntax.hs +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -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)) diff --git a/suckless-conf.cabal b/suckless-conf.cabal index 4995dba..0b0456b 100644 --- a/suckless-conf.cabal +++ b/suckless-conf.cabal @@ -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: diff --git a/test/Data/Config/Suckless/AesonSpec.hs b/test/Data/Config/Suckless/AesonSpec.hs index c1ae8d8..ae48a9d 100644 --- a/test/Data/Config/Suckless/AesonSpec.hs +++ b/test/Data/Config/Suckless/AesonSpec.hs @@ -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) + + diff --git a/test/Data/Config/Suckless/KeyValueSpec.hs b/test/Data/Config/Suckless/KeyValueSpec.hs index a9f09e0..dc40a5e 100644 --- a/test/Data/Config/Suckless/KeyValueSpec.hs +++ b/test/Data/Config/Suckless/KeyValueSpec.hs @@ -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