wip, ncq migrate script

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)
+
+

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
+        entry $ bindMatch "stdin" $ nil_ $ \case
-          (StringLike what : args) -> liftIO do
+          argz  -> do
+            liftIO getContents >>= runScript dict argz
 
-            liftIO (readFile what)
+        entry $ bindMatch "file" $ nil_ $ \case
-              <&> parseTop
+          ( StringLike fn : argz ) -> do
-              >>= either (error.show) pure
+            liftIO (readFile fn) >>= runScript dict argz
-              >>= \syn -> do
-                    runTM tvd do
 
-                      for_ (zip [1..] args) $ \(i,a) -> do
+          e -> error (show $ pretty $ mkList e)
-                        let n = Id ("$" <> fromString (show i))
-                        SC.bind n a
 
-                      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)
+  flip runContT pure do
-    `finally` (finalizeStorages >> flushLoggers)
+
+    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)
 
 
 

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