wip

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

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)

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
+

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:"
+
+
+

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
 

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 ]
+         let wat = mkList [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
-         pure $ mkForm "dict" wat
+         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
+      [k, ListVal es ] -> do
-        let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
+        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)
+
+