wip10, missed stuff

hbs2-tests/test/TestScripts.hs

@@ -0,0 +1,158 @@
+module Main where
+
+import HBS2.Prelude.Plated
+
+import HBS2.System.Logger.Simple.ANSI as Exported
+import HBS2.System.Dir
+import HBS2.Misc.PrettyStuff as Exported
+
+import Data.Config.Suckless.Script
+import Data.Config.Suckless.Script.File
+
+import Data.List (sort,foldl')
+import Control.Monad.Trans.Cont
+import System.Environment qualified as E
+import System.Exit (exitSuccess)
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Codec.Serialise
+import Lens.Micro.Platform
+import Streaming.Prelude qualified as S
+
+-- debugPrefix :: LoggerEntry -> LoggerEntry
+debugPrefix = toStderr . logPrefix "[debug] "
+
+setupLogger :: MonadIO m => m ()
+setupLogger = do
+  setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+  setLogging @ERROR  $ toStderr . logPrefix "[error] "
+  setLogging @WARN   $ toStderr . logPrefix "[warn] "
+  setLogging @NOTICE $ toStdout . logPrefix ""
+  pure ()
+
+flushLoggers :: MonadIO m => m ()
+flushLoggers = do
+  silence
+
+silence :: MonadIO m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+type TestScripPerks m = ( MonadIO m, MonadUnliftIO m)
+
+quit :: MonadIO m => m ()
+quit = liftIO exitSuccess
+
+data E a =
+  N (Map FilePath (E a)) | L a
+  deriving stock (Eq,Ord,Generic)
+
+instance Serialise a => Serialise (E a)
+
+-- newtype Directory = Directory (HashMap FilePath E)
+--                     deriving stock (Generic)
+--                     deriving newtype (Eq,Show,Semigroup,Monoid)
+
+-- instance Serialise Directory
+
+-- Вставка одного пути в структуру
+insert :: [FilePath] -> a -> E a -> E a
+insert [] v (N children) = L v  -- Если дошли до конца пути, превращаем узел в лист с значением
+insert [] _ (L v) = L v         -- Если уже лист, оставляем его как есть
+insert (p:ps) v (N children) =  -- Если остались элементы пути, продолжаем вставку
+    N (Map.alter update p children)
+  where
+    update Nothing = Just (insert ps v (N Map.empty))
+    update (Just child) = Just (insert ps v child)
+insert _ _ (L _) = error "assertion"
+
+buildTrie :: [([FilePath], a)] -> E a
+buildTrie paths = foldl' (\trie (path, v) -> insert path v trie) (N Map.empty) paths
+
+-- Преобразование структуры в список путей с значениями
+toList :: E a -> [([FilePath], a)]
+toList = go []
+  where
+    go prefix (L v) = [(prefix, v)]
+    go prefix (N children) = concatMap (\(p, subtree) -> go (prefix ++ [p]) subtree) (Map.toList children)
+
+
+listDirFiles :: MonadIO m => FilePath -> m [FilePath]
+listDirFiles root = do
+  S.toList_ <$> glob ["**/*"] [] root $ \fn -> do
+    S.yield fn
+    pure True
+
+-- buildDirectory :: [FilePath] -> Directory
+-- buildDirectory entries = do
+  -- get entry
+  --   split entry
+  --     for each part:
+  --
+  -- mempty
+
+
+theDict :: forall m . ( TestScripPerks m
+                      ) => Dict C m
+theDict = do
+  makeDict @C do
+    -- TODO: write-man-entries
+    myHelpEntry
+  where
+
+    myHelpEntry = do
+        entry $ bindMatch "--help" $ nil_ $ \case
+          HelpEntryBound what -> do
+            helpEntry what
+            quit
+
+          _ -> helpList False Nothing >> quit
+
+        entry $ bindMatch "hello" $ nil_ $ const $ do
+          liftIO $ putStrLn "hello"
+
+        entry $ bindMatch "dir:list" $ nil_ $ \syn -> do
+          let root = case syn of
+                       [StringLike p] -> p
+                       _ -> "."
+
+          what <- listDirFiles root <&> sort
+
+          liftIO $ mapM_ putStrLn what
+
+        entry $ bindMatch "dir:list:build" $ nil_ $ \syn -> do
+          let root = case syn of
+                       [StringLike p] -> p
+                       _ -> "."
+
+          what <- listDirFiles root <&> fmap ((, ()) . splitPath)
+
+          let trie = buildTrie what
+
+          liftIO $ LBS.hPutStr stdout (serialise what) >> hFlush stdout
+
+main :: IO ()
+main = flip runContT pure do
+
+  setupLogger
+
+  ContT $ bracket none $ const do
+    silence
+
+  argz <- liftIO $ E.getArgs
+  cli <- parseTop (unlines $ unwords <$> splitForms argz)
+           & either  (error.show) pure
+
+  let dict = theDict
+  void $ lift $ run dict cli
+
+
+
+