diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index 67951e7d..a5c13ce0 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -9,6 +9,8 @@ module Data.Config.Suckless.Script.Internal ) where import Data.Config.Suckless +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Parse.Fuzzy as P import Data.Config.Suckless.Almost.RPC import Data.Traversable @@ -17,6 +19,10 @@ import Control.Monad import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Writer +import Data.Aeson as Aeson +import Data.Yaml qualified as Yaml +import Data.Ini qualified as Ini +import Data.Ini (Ini(..)) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.ByteString qualified as BS @@ -226,39 +232,6 @@ display_ = liftIO . print {- HLINT ignore "Functor law" -} -class IsContext c => MkSym c a where - mkSym :: a -> Syntax c - -instance IsContext c => MkSym c String where - mkSym s = Symbol noContext (Id $ Text.pack s) - -instance IsContext c => MkSym c Text where - mkSym s = Symbol noContext (Id s) - -instance IsContext c => MkSym c Id where - mkSym = Symbol noContext - -class IsContext c => MkStr c s where - mkStr :: s -> Syntax c - -instance IsContext c => MkStr c String where - mkStr s = Literal noContext $ LitStr (Text.pack s) - -instance IsContext c => MkStr c Text where - mkStr s = Literal noContext $ LitStr s - -mkBool :: forall c . IsContext c => Bool -> Syntax c -mkBool v = Literal noContext (LitBool v) - - -class IsContext c => MkForm c a where - mkForm :: a-> [Syntax c] -> Syntax c - -instance (IsContext c, MkSym c s) => MkForm c s where - mkForm s sy = List noContext ( mkSym @c s : sy ) - -mkList :: forall c. IsContext c => [Syntax c] -> Syntax c -mkList = List noContext isFalse :: forall c . IsContext c => Syntax c -> Bool isFalse = \case @@ -271,18 +244,6 @@ eatNil f = \case Nil -> pure () x -> void $ f x -class IsContext c => MkInt c s where - mkInt :: s -> Syntax c - -class IsContext c => MkDouble c s where - mkDouble :: s -> Syntax c - -instance (IsContext c, RealFrac s) => MkDouble c s where - mkDouble v = Literal noContext $ LitScientific (realToFrac v) - -instance (Integral i, IsContext c) => MkInt c i where - mkInt n = Literal noContext $ LitInt (fromIntegral n) - class OptionalVal c b where optional :: b -> Syntax c -> b @@ -799,8 +760,6 @@ lookupValue i = do Just (BindValue s) -> pure s _ -> throwIO (NameNotBound i) -nil :: forall c . IsContext c => Syntax c -nil = List noContext [] nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) nil_ m w = m w >> pure (List noContext []) @@ -824,6 +783,21 @@ fmt = \case LitStrVal x -> pretty $ Text.unpack x x -> pretty x +newtype IniConfig = IniConfig Ini.Ini + +instance IsContext c => MkSyntax c IniConfig where + mkSyntax (IniConfig (Ini{..})) = do + + let section kvs = [ mkList [mkSym k, either (const (mkStr v)) fixContext (P.parseSyntax v)] + | (k,v) <- kvs + ] + + let globals = section iniGlobals + + let sections = [ mkForm @c s (section pps) | (s, pps) <- HM.toList iniSections ] + + mkList (globals <> sections) + internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () internalEntries = do @@ -1175,12 +1149,37 @@ internalEntries = do e@(SymbolVal x) -> wrapWith e _ -> id + entry $ bindMatch "json:stdin" $ const do + parseJson <$> liftIO (LBS.hGetContents stdin) + + entry $ bindMatch "json:file" $ \case + [StringLike fn] -> do + parseYaml <$> liftIO (LBS.readFile fn) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "yaml:stdin" $ const do + parseYaml <$> liftIO (LBS.hGetContents stdin) + + entry $ bindMatch "yaml:file" $ \case + [StringLike fn] -> do + parseYaml <$> liftIO (LBS.readFile fn) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "ini:stdin" $ const do + parseIni <$> liftIO (LBS.hGetContents stdin) + + entry $ bindMatch "ini:file" $ \case + [StringLike fn] -> do + parseIni <$> liftIO (LBS.readFile fn) + + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "top:stdin" $ const do liftIO TIO.getContents <&> either (const nil) (mkList . fmap fixContext) . parseTop - entry $ bindMatch "top:file" $ \case [StringLike fn] -> do liftIO $ TIO.readFile fn @@ -1388,9 +1387,26 @@ internalEntries = do _ -> pure nil +parseJson :: forall c . IsContext c => LBS.ByteString -> Syntax c +parseJson input = case Aeson.decode @Value input of + Just val -> mkSyntax @c val + Nothing -> nil + +parseYaml :: forall c . IsContext c => LBS.ByteString -> Syntax c +parseYaml input = + case Yaml.decodeEither' @Value (LBS.toStrict input) of + Left _ -> nil @c + Right val -> mkSyntax @c val + +parseIni :: forall c . IsContext c => LBS.ByteString -> Syntax c +parseIni input = + case Ini.parseIni (decodeUtf8With ignore $ LBS.toStrict input) of + Left _ -> nil + Right ini -> mkSyntax @c (IniConfig ini) matchOne :: IsContext c => Text -> Syntax c -> Bool matchOne what = \case s@(TextLike x) | Text.isInfixOf what x -> True e@(ListVal xs) -> or [ Text.isInfixOf what s | TextLike s <- xs ] _ -> False + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index 75fa4a21..89ed567f 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -22,6 +22,15 @@ module Data.Config.Suckless.Syntax , fromOpaqueThrow , isByteString , SyntaxTypeError(..) + , nil + , mkList + , mkBool + , MkForm(..) + , MkSym(..) + , MkInt(..) + , MkStr(..) + , MkDouble(..) + , MkSyntax(..) , pattern SymbolVal , pattern ListVal , pattern LitIntVal @@ -45,7 +54,7 @@ import Data.Scientific import GHC.Generics (Generic(..)) import Data.Maybe import Data.Aeson -import Data.Aeson.Key +import Data.Aeson.Key as Aeson import Data.Aeson.KeyMap qualified as Aeson import Data.Vector qualified as V import Data.Traversable (forM) @@ -145,6 +154,9 @@ class HasContext c a where class IsLiteral a where mkLit :: a -> Literal +class IsContext c => ToSyntax c a where + toSyntax :: a -> Syntax c + newtype Id = Id Text deriving newtype (IsString,Pretty,Semigroup,Monoid) @@ -312,4 +324,66 @@ instance IsContext c => FromJSON (Syntax c) where pure $ List noContext (Symbol noContext (Id "object") : pairs) parseJSON _ = fail "Cannot parse JSON to Syntax" +class IsContext c => MkSym c a where + mkSym :: a -> Syntax c + +instance IsContext c => MkSym c String where + mkSym s = Symbol noContext (Id $ Text.pack s) + +instance IsContext c => MkSym c Text where + mkSym s = Symbol noContext (Id s) + +instance IsContext c => MkSym c Id where + mkSym = Symbol noContext + +class IsContext c => MkStr c s where + mkStr :: s -> Syntax c + +instance IsContext c => MkStr c String where + mkStr s = Literal noContext $ LitStr (Text.pack s) + +instance IsContext c => MkStr c Text where + mkStr s = Literal noContext $ LitStr s + +mkBool :: forall c . IsContext c => Bool -> Syntax c +mkBool v = Literal noContext (LitBool v) + +nil :: forall c . IsContext c => Syntax c +nil = List noContext [] + +class IsContext c => MkForm c a where + mkForm :: a-> [Syntax c] -> Syntax c + +instance (IsContext c, MkSym c s) => MkForm c s where + mkForm s sy = List noContext ( mkSym @c s : sy ) + +mkList :: forall c. IsContext c => [Syntax c] -> Syntax c +mkList = List noContext + +class IsContext c => MkInt c s where + mkInt :: s -> Syntax c + +class IsContext c => MkDouble c s where + mkDouble :: s -> Syntax c + +instance (IsContext c, RealFrac s) => MkDouble c s where + mkDouble v = Literal noContext $ LitScientific (realToFrac v) + +instance (Integral i, IsContext c) => MkInt c i where + mkInt n = Literal noContext $ LitInt (fromIntegral n) + +class MkSyntax c a where + mkSyntax :: a -> Syntax c + +instance IsContext c => MkSyntax c (Syntax c) where + mkSyntax = id + +instance IsContext c => MkSyntax c Value where + mkSyntax Null = nil + mkSyntax (Number n) = mkDouble n + mkSyntax (String n) = mkStr n + mkSyntax (Bool b) = mkBool b + mkSyntax (Array ns) = mkList [ mkSyntax n | n <- V.toList ns] + mkSyntax (Object kv) = mkList [ mkList [mkSym (Aeson.toText k), mkSyntax v] | (k,v) <- Aeson.toList kv] + diff --git a/miscellaneous/suckless-conf/suckless-conf.cabal b/miscellaneous/suckless-conf/suckless-conf.cabal index b6f89efe..99239949 100644 --- a/miscellaneous/suckless-conf/suckless-conf.cabal +++ b/miscellaneous/suckless-conf/suckless-conf.cabal @@ -84,6 +84,7 @@ library , filepattern , fuzzy-parse >= 0.1.3.1 , hashable + , ini , interpolatedstring-perl6 , microlens-platform , mtl @@ -96,10 +97,12 @@ library , text , time , transformers + , toml-parser , typed-process , unliftio , unordered-containers , vector + , yaml hs-source-dirs: lib default-language: Haskell2010