From 6a04798c8e21fbc1434f638cafd72648833fcc62 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 20 May 2025 09:18:10 +0300 Subject: [PATCH] wip, ncq migrate script --- bf6/ncq-migrate.ss | 65 +++++++++++++++++++ hbs2-tests/test/TCQ.hs | 64 +++++++++++++----- .../Data/Config/Suckless/Script/Internal.hs | 36 ++++++++++ 3 files changed, 148 insertions(+), 17 deletions(-) create mode 100644 bf6/ncq-migrate.ss diff --git a/bf6/ncq-migrate.ss b/bf6/ncq-migrate.ss new file mode 100644 index 00000000..d79a7513 --- /dev/null +++ b/bf6/ncq-migrate.ss @@ -0,0 +1,65 @@ + +(define STORAGE (path:join (env HOME) .local/share/hbs2 )) +(define REFS (path:join STORAGE refs) ) +(define BLOCKS (path:join STORAGE blocks) ) +(define NEW (path:join (env HOME) tmp/ncq0)) + + +(define refs (glob REFS '[*/**] )) +(define blocks (glob BLOCKS '[*/**] )) + +(define (readref x) + (begin + (local ref (concat (reverse (take 2 (reverse (split :/ x)))))) + (local refval (str:file x)) + `(,(sym ref) ,(sym refval)))) + +(define (readhash x) + (sym (concat (reverse (take 2 (reverse (split :/ x)))))) +) + +(local zu (map readref refs)) + +; (println zu) + +(println STORAGE) +(println NEW) + +; debug +(define ncq (ncq:open NEW)) + +(define (writeref x) + (match x + ( (list? a b ) + (begin + (ncq:set:ref ncq a b) + (println ref space a space b) + ) + ) + (_ '()) + )) + +(define (import-refs) (for zu writeref)) + +(define (import-blocks) + (begin + ; (local (write x) (ncq:put ncq (bytes:file x))) + (for blocks (fn x . + (begin + (local ha (sym (ncq:put ncq (bytes:strict:file x)))) + (local h0 (sym (readhash x))) + (local s (coalesce "" (ncq:has ncq ha))) + (local ok (if (eq? ha h0) (ansi :green _ ok) (ansi :red _ fail))) + (println block space ok space (align -6 (str s)) space ha space h0 space ) + (if (not (eq? ha h0)) (die "*** block import error:" ha space h0)) + ))) + ) +) + +(import-blocks) +(import-refs) + + +; ; (println OKAY) + + diff --git a/hbs2-tests/test/TCQ.hs b/hbs2-tests/test/TCQ.hs index 9240f5fd..43b020bd 100644 --- a/hbs2-tests/test/TCQ.hs +++ b/hbs2-tests/test/TCQ.hs @@ -27,6 +27,7 @@ import HBS2.CLI.Run.Internal.Merkle import Data.Config.Suckless.Syntax import Data.Config.Suckless.Script as SC import Data.Config.Suckless.System +import Data.Config.Suckless.Script.File as SF import DBPipe.SQLite hiding (field) @@ -116,6 +117,12 @@ main = do tvd <- newTVarIO mempty + let runScript dict argz what = liftIO do + script <- either (error.show) pure $ parseTop what + runM dict do + bindCliArgs argz + void $ evalTop script + let finalizeStorages = do debug "finalize ncq" r <- readTVarIO instances <&> HM.toList @@ -141,27 +148,20 @@ main = do _ -> helpList False Nothing internalEntries + SF.entries entry $ bindMatch "#!" $ nil_ $ const none - entry $ bindMatch "--run" $ \case - (StringLike what : args) -> liftIO do + entry $ bindMatch "stdin" $ nil_ $ \case + argz -> do + liftIO getContents >>= runScript dict argz - liftIO (readFile what) - <&> parseTop - >>= either (error.show) pure - >>= \syn -> do - runTM tvd do + entry $ bindMatch "file" $ nil_ $ \case + ( StringLike fn : argz ) -> do + liftIO (readFile fn) >>= runScript dict argz - for_ (zip [1..] args) $ \(i,a) -> do - let n = Id ("$" <> fromString (show i)) - SC.bind n a + e -> error (show $ pretty $ mkList e) - SC.bind "$argv" (mkList args) - - evalTop syn - - e -> throwIO $ BadFormException @C (mkList e) entry $ bindMatch "debug" $ nil_ \case @@ -498,8 +498,38 @@ pragma synchronous=normal; atomically $ writeTVar tvd dict - (runEval tvd forms >>= eatNil display) - `finally` (finalizeStorages >> flushLoggers) + flip runContT pure do + + ContT $ bracket none $ const do + finalizeStorages + flushLoggers + + lift do + case forms of + + ( cmd@(ListVal [StringLike "file", StringLike fn]) : _ ) -> do + void $ run dict [cmd] + + ( cmd@(ListVal [StringLike "stdin"]) : _ ) -> do + void $ run dict [cmd] + + ( cmd@(ListVal [StringLike "--help"]) : _ ) -> do + void $ run dict [cmd] + + [] -> do + eof <- liftIO IO.isEOF + if eof then + void $ run dict [mkForm "help" []] + else do + what <- liftIO getContents + >>= either (error.show) pure . parseTop + + run dict what >>= eatNil display + + e -> void $ run dict e + + -- (runEval tvd forms >>= eatNil display) + -- `finally` (finalizeStorages >> flushLoggers) 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 fcf0dde6..21dcd6b6 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -1417,9 +1417,26 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "coalesce" $ \case + [a] -> pure a + [a,b] | isFalse b -> pure a + [a,_] -> pure a + _ -> pure nil + + entry $ bindAlias "nvl" "coalesce" --TODO: integral sum + entry $ bindMatch "align" $ \syn -> do + (n,f,s) <- case syn of + [ LitIntVal n, TextLike s ] -> pure (n,' ',s) + [ LitIntVal n, TextLike f, TextLike s ] -> pure (n, maybe ' ' fst (Text.uncons f) ,s) + e -> throwIO (BadFormException @c (mkList e)) + + let shift = fromIntegral $ abs n + let fn = if n >= 0 then Text.justifyLeft else Text.justifyRight + pure $ mkStr (fn shift f s) + entry $ bindMatch "upper" $ \case [ LitStrVal x ] -> pure $ mkStr $ Text.toUpper x [ SymbolVal (Id x) ] -> pure $ mkStr $ Text.toUpper x @@ -1591,6 +1608,8 @@ internalEntries = do let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty other) mkStr s + + entry $ bindMatch "ansi" $ \case [ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do let b = case join (HM.lookup bg colorz) of @@ -1994,6 +2013,14 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + brief "reads bytes from a file" + $ desc "bytes:strict:file FILE" + $ entry $ bindMatch "bytes:strict:file" $ \case + [ StringLike fn ] -> do + liftIO (BS.readFile fn) >>= mkOpaque + + _ -> throwIO (BadFormException @c nil) + brief "reads bytes from a STDIN" $ desc "bytes:stdin" $ entry $ bindMatch "bytes:stdin" $ \case @@ -2218,6 +2245,15 @@ internalEntries = do _ -> pure nil + entry $ bindMatch "path:join" $ \case + StringLikeList es -> lift do + pure $ mkSym (joinPath es) + + [ ListVal (StringLikeList es) ] -> do + pure $ mkSym (joinPath es) + + _ -> pure nil + entry $ bindMatch "path:exists?" $ \case [ StringLike p ] -> lift do liftIO (Dir.doesPathExist p) <&> mkBool