From 2804332ae9bbe3f5ad1feb371c1d4aa45d7432cb Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 24 Jan 2025 11:59:25 +0300 Subject: [PATCH] wip --- hbs2-git3/hbs2-git3.cabal | 1 + hbs2-git3/lib/HBS2/Git3/Repo.hs | 2 +- hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs | 55 +++++++++++++++++++ hbs2-git3/lib/HBS2/Git3/Run.hs | 12 +++- .../lib/Data/Config/Suckless/Almost/RPC.hs | 3 +- .../Data/Config/Suckless/Script/Internal.hs | 46 +++++++++++++--- 6 files changed, 107 insertions(+), 12 deletions(-) create mode 100644 hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index cb540eea..3b9038e8 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -126,6 +126,7 @@ library HBS2.Git3.Export HBS2.Git3.Import HBS2.Git3.Repo + HBS2.Git3.Repo.Fork HBS2.Git3.Run HBS2.Git3.Logger HBS2.Git3.State diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index 9cbaca75..3bd7e491 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -82,7 +82,7 @@ initRepo syn = do & lastMay & orThrowUser "can't create new lwwref" - liftIO $ appendFile root (show $ pretty $ mkForm "repo:key" [mkSym @C (show $ pretty (AsBase58 pk))]) + liftIO $ appendFile root (show $ pretty $ mkForm "repo:ref" [mkSym @C (show $ pretty (AsBase58 pk))]) CheckRepoKeyStart pk -> do debug $ "initRepo:CheckRepoKeyStart" <+> pretty (AsBase58 pk) diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs new file mode 100644 index 00000000..72d57373 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs @@ -0,0 +1,55 @@ +module HBS2.Git3.Repo.Fork (forkEntries) where + +import HBS2.Git3.Prelude +import HBS2.Git3.State +import HBS2.Git3.Git +import HBS2.Data.Detect + +import HBS2.Data.Log.Structured + +import HBS2.CLI.Run.Internal.Merkle (createTreeWithMetadata) +-- import HBS2.CLI.Run.RefLog (mkRefLogUpdateFrom) + +import HBS2.System.Dir + +import HBS2.Git3.Config.Local + +import Data.Config.Suckless.Script +import Data.Config.Suckless.Almost.RPC + +import Codec.Compression.Zstd.Streaming qualified as ZstdS +import Codec.Compression.Zstd.Streaming (Result(..)) +import Data.ByteString.Builder as Builder +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString qualified as BS +import Data.ByteString (ByteString) +import Data.Fixed +import Data.HashPSQ qualified as HPSQ +import Data.HashPSQ (HashPSQ) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.List qualified as L +import Data.List (sortBy) +import Data.List.Split (chunksOf) +import Data.Ord (comparing) +import Lens.Micro.Platform +import Streaming.Prelude qualified as S +import System.IO (hPrint) +import System.IO qualified as IO +import System.IO.Temp as Temp +import UnliftIO.Concurrent + + +forkEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) () +forkEntries prefix = do + entry $ bindMatch (prefix <> "fork") $ nil_ $ \case + [ SignPubKeyLike what ] -> lift $ connectedDo do + error $ show $ "not yet" <+> pretty (AsBase58 what) + + r <- callProc "git" ["--init"] [] + none + + _ -> throwIO $ BadFormException @C nil + diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 9e5a84be..4bf44aef 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -12,9 +12,11 @@ import HBS2.Git3.Export import HBS2.Git3.Import import HBS2.Git3.State import HBS2.Git3.Repo qualified as Repo +import HBS2.Git3.Repo.Fork (forkEntries) import HBS2.Git3.Logger import Data.Config.Suckless.Script +import Data.Config.Suckless.Almost.RPC import Codec.Compression.Zstd.Lazy qualified as ZstdL @@ -407,6 +409,8 @@ compression ; prints compression level entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do + waitRepo Nothing + let (opts, _) = splitOpts [ ("--checkpoints",0) , ("--segments",0) ] syn @@ -471,9 +475,9 @@ compression ; prints compression level $ desc "needed when you call hbs2-git command directly" $ examples [qc| ; in config: -repo:key EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk +repo:ref EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk -repo:key ; shows current repo key +repo:ref ; shows current repo key |] $ entry $ bindMatch "repo:ref" $ nil_ $ \case [ SignPubKeyLike k ] -> lift do @@ -501,3 +505,7 @@ repo:key ; shows current repo key exportEntries "reflog:" + forkEntries "repo:" + + + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs index 6725bb2e..4fe4e16b 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs @@ -23,7 +23,7 @@ data CallProcException = instance Exception CallProcException -- FIXME: to-suckless-script -callProc :: forall m . (MonadIO m) +callProc :: forall m . MonadIO m => FilePath -> [String] -> [Syntax C] @@ -34,6 +34,7 @@ callProc name params syn = do & LBS8.unlines & byteStringInput + let what = proc name params & setStderr closed & setStdin input (code, i, _) <- readProcess what 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 c670a55c..a268de4d 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,7 @@ module Data.Config.Suckless.Script.Internal ) where import Data.Config.Suckless +import Data.Config.Suckless.Almost.RPC import Control.Applicative import Control.Monad @@ -796,6 +797,11 @@ fixContext = go Literal _ l -> Literal noContext l OpaqueValue box -> OpaqueValue box +-- quotList :: forall c . IsContext c => Syntax c -> Syntax c +-- quotList = \case +-- ListVal (x:xs) | x /= mkSym "quot" -> mkList (mkSym "quot" : x : xs) +-- e -> e + fmt :: Syntax c -> Doc ann fmt = \case LitStrVal x -> pretty $ Text.unpack x @@ -851,9 +857,9 @@ internalEntries = do entry $ bindMatch "dict" $ \case (pairList -> es@(_:_)) -> do - pure $ mkForm "dict" es + pure $ mkList es [a, b] -> do - pure $ mkForm "dict" [ mkList [a, b] ] + pure $ mkList [ mkList [a, b] ] _ -> throwIO (BadFormException @C nil) brief "creates a dict from a linear list of string-like items" @@ -880,8 +886,8 @@ internalEntries = do (dict (a b) (c ())) |] $ entry $ bindMatch "kw" $ \syn -> do - let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] - pure $ mkForm "dict" wat + let wat = mkList [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] + pure $ wat entry $ bindMatch "iterate" $ nil_ $ \syn -> do case syn of @@ -940,7 +946,7 @@ internalEntries = do throwIO (BadFormException @C nil) entry $ bindMatch "quasiquot" $ \case - [ syn ] -> mkList . List.singleton <$> (evalQQ mempty) syn + [ syn ] -> mkList . List.singleton <$> evalQQ mempty syn _ -> do throwIO (BadFormException @C nil) @@ -962,9 +968,22 @@ internalEntries = do [ListVal es] -> pure $ mkList (tail es) _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "nth" $ \case + [ LitIntVal i, ListVal es ] -> pure $ atDef nil es (fromIntegral i) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "assoc" $ \case + [k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ] + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "assoc:nth" $ \case + [LitIntVal i, k, ListVal es ] -> do + pure $ headDef nil [ r | r@(ListVal ys) <- es, atMay ys (fromIntegral i) == Just k ] + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "lookup" $ \case - [s, ListVal (SymbolVal "dict" : es) ] -> do - let val = headDef nil [ v | ListVal [k, v] <- es, k == s ] + [k, ListVal es ] -> do + let val = headDef nil [ mkList rest | ListVal (w:rest) <- es, k == w ] pure val [StringLike s, ListVal [] ] -> do @@ -1172,7 +1191,7 @@ internalEntries = do $ entry $ bindMatch "env" $ \case [] -> do s <- liftIO getEnvironment - pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ] + pure $ mkList [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ] [StringLike s] -> do liftIO (lookupEnv s) @@ -1266,3 +1285,14 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + brief "calls external process" + $ entry $ bindMatch "call:proc" \case + [StringLike what] -> lift do + callProc what mempty mempty <&> mkList @c . fmap (mkForm "quot" . List.singleton . fixContext) + + StringLikeList (x:xs) -> lift do + callProc x xs mempty <&> mkList @c . fmap (mkForm "quot" . List.singleton . fixContext) + + _ -> throwIO (BadFormException @c nil) + +