wip

.fixme-new/config

@@ -30,77 +30,3 @@ fixme-file-comments "*.scm" ";"
 
 fixme-comments ";" "--"
 
-(update-action
-  (import-git-logs ".fixme-new/log")
-)
-
-(update-action
-  (import ".fixme-new/fixme.log")
-)
-
-(update-action
-  (export ".fixme-new/fixme.log")
-)
-
-
-(update-action
-  (hello kitty)
-)
-
-(define-macro done
-  (modify $1 workflow done)
-)
-
-(define-macro wip
-  (modify $1 workflow wip)
-)
-
-(define-macro test
-  (modify $1 workflow test)
-)
-
-(define-macro backlog
-  (modify $1 workflow backlog)
-)
-
-(define-macro fixed
-  (modify $1 workflow fixed)
-)
-
-(define-macro new
-  (modify $1 workflow new)
-)
-
-(define-macro stage
-  (builtin:show-stage))
-
-(define-macro log
-  (builtin:show-log .fixme-new/fixme.log))
-
-
-(define-template short
-  (simple
-     (trim 10  $fixme-key) " "
-
-     (if (~ FIXME $fixme-tag)
-      (then (fgd red (align 6  $fixme-tag))  )
-      (else (if (~ TODO $fixme-tag)
-              (then (fgd green (align 6  $fixme-tag)))
-              (else (align 6  $fixme-tag)) ) )
-      )
-
-
-     (align 10  ("[" $workflow "]"))  " "
-     (align 8  $type)  " "
-     (align 12 $assigned)  " "
-     (align 20 (trim 20 $committer-name)) " "
-     (trim 50  ($fixme-title)) " "
-     (nl)
-  )
-)
-
-(set-template default short)
-
-; update
-
-

fixme-new/fixme.cabal

@@ -104,6 +104,9 @@ common shared-properties
 library
     import:           shared-properties
 
+    other-modules:
+      Fixme.Run.Internal
+
     exposed-modules:
       Fixme
       Fixme.Config

fixme-new/lib/Fixme/Run.hs

@@ -5,6 +5,7 @@ import Fixme.Prelude hiding (indent)
 import Fixme.Types
 import Fixme.Config
 import Fixme.State
+import Fixme.Run.Internal
 import Fixme.Scan.Git.Local as Git
 import Fixme.Scan as Scan
 import Fixme.Log
@@ -126,34 +127,11 @@ readConfig = do
 
   pure $ mconcat w
 
-init :: FixmePerks m => FixmeM m ()
-init = do
-
-  lo <- localConfigDir
-
-  let lo0 = takeFileName lo
-
-  mkdir lo
-  touch (lo </> "config")
-
-  let gitignore = lo </> ".gitignore"
-  here <- doesPathExist gitignore
-
-  unless here do
-    liftIO $ writeFile gitignore $ show $
-      vcat [ pretty ("." </> localDBName)
-           ]
-
-  notice $ yellow "run" <> line <> vcat [
-      "git add" <+> pretty (lo0  </> ".gitignore")
-    , "git add" <+> pretty (lo0  </> "config")
-    ]
-
 
 runTop :: FixmePerks m => [String] -> FixmeM m ()
-runTop args = do
+runTop argz = do
 
-  forms <- parseTop (unlines $ unwords <$> splitForms args)
+  forms <- parseTop (unlines $ unwords <$> splitForms argz)
            & either  (error.show) pure
 
   -- pure ((unlines . fmap unwords . splitForms) what)
@@ -168,6 +146,78 @@ runTop args = do
          [StringLike s]      -> helpList False (Just s)
          _                   -> helpList False Nothing
 
+       entry $ bindMatch "fixme-prefix" $ nil_ \case
+        [StringLike pref] -> do
+
+          t <- lift $ asks fixmeEnvTags
+          atomically (modifyTVar t (HS.insert (FixmeTag $ fromString pref)))
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "fixme-git-scan-filter-days" $ nil_ \case
+        [LitIntVal d] -> do
+          t <- lift $ asks fixmeEnvGitScanDays
+          atomically (writeTVar t (Just d))
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-attribs" $ nil_ \case
+        StringLikeList xs -> do
+          ta <- lift $ asks fixmeEnvAttribs
+          atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+
+       entry $ bindMatch "fixme-files" $ nil_ \case
+        StringLikeList xs -> do
+          t <- lift $ asks fixmeEnvFileMask
+          atomically (modifyTVar t (<> xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-file-comments" $ nil_ $ \case
+         [StringLike ft, StringLike b] -> do
+            let co = Text.pack b & HS.singleton
+            t <- lift $ asks fixmeEnvFileComments
+            atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-comments" $ nil_  \case
+         (StringLikeList xs) -> do
+            t <- lift $ asks fixmeEnvDefComments
+            let co = fmap Text.pack xs & HS.fromList
+            atomically $ modifyTVar t (<> co)
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch  "fixme-value-set" $ nil_ \case
+         (StringLikeList (n:xs))  -> do
+           t <- lift $ asks fixmeEnvAttribValues
+           let name = fromString n
+           let vals = fmap fromString xs & HS.fromList
+           atomically $ modifyTVar t (HM.insertWith (<>) name vals)
+
+         _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-pager" $ nil_ \case
+        _ -> warn $ yellow "fixme-pager" <+> "instruction is not supported yet"
+
+       entry $ bindMatch "fixme-def-context" $ nil_ \case
+        [LitIntVal a, LitIntVal b] -> do
+          t <- lift $ asks fixmeEnvCatContext
+          atomically $ writeTVar t (fromIntegral a, fromIntegral b)
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "env:show" $ nil_ $ const $ do
+        lift printEnv
+
+       entry $ bindMatch "init" $ nil_ $ const $ do
+        lift init
+
   conf <- readConfig
 
   run dict (conf <> forms) >>= eatNil display

fixme-new/lib/Fixme/Run/Internal.hs

@@ -0,0 +1,131 @@
+module Fixme.Run.Internal where
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.Config
+import Fixme.State
+import Fixme.Scan.Git.Local as Git
+import Fixme.Scan as Scan
+import Fixme.Log
+
+import HBS2.Git.Local.CLI
+
+import HBS2.Base58
+import HBS2.Merkle
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Storage.Compact
+import HBS2.System.Dir
+import DBPipe.SQLite hiding (field)
+import Data.Config.Suckless
+
+import Data.Aeson.Encode.Pretty as Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Either
+import Data.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
+import Data.Set qualified as Set
+import Data.Generics.Product.Fields (field)
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Control.Monad.Identity
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import System.IO.Temp as Temp
+import System.IO qualified as IO
+
+
+import Streaming.Prelude qualified as S
+
+
+
+init :: FixmePerks m => FixmeM m ()
+init = do
+
+  lo <- localConfigDir
+
+  let lo0 = takeFileName lo
+
+  mkdir lo
+  touch (lo </> "config")
+
+  let gitignore = lo </> ".gitignore"
+  here <- doesPathExist gitignore
+
+  unless here do
+    liftIO $ writeFile gitignore $ show $
+      vcat [ pretty ("." </> localDBName)
+           ]
+
+  notice $ yellow "run" <> line <> vcat [
+      "git add" <+> pretty (lo0  </> ".gitignore")
+    , "git add" <+> pretty (lo0  </> "config")
+    ]
+
+
+printEnv :: FixmePerks m => FixmeM m ()
+printEnv = do
+  g <- asks fixmeEnvGitDir >>= readTVarIO
+  masks <- asks fixmeEnvFileMask >>= readTVarIO
+  tags  <- asks fixmeEnvTags >>= readTVarIO
+  days  <- asks fixmeEnvGitScanDays >>= readTVarIO
+  comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
+
+  comments2 <- asks fixmeEnvFileComments >>= readTVarIO
+                 <&> HM.toList
+                 <&> fmap  (over _2 HS.toList)
+
+  attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
+  vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
+
+  for_ tags $ \m -> do
+    liftIO $ print $ "fixme-prefix" <+> pretty m
+
+  for_ masks $ \m -> do
+    liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
+
+  for_ days $ \d -> do
+    liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
+
+  for_ comments1 $ \d -> do
+    liftIO $ print $ "fixme-comments" <+> dquotes (pretty d)
+
+  for_ comments2 $ \(ft, comm') -> do
+    for_ comm' $ \comm -> do
+      liftIO $ print $ "fixme-file-comments"
+                  <+> dquotes (pretty ft) <+> dquotes (pretty  comm)
+
+  for_ attr $ \a -> do
+      liftIO $ print $ "fixme-attribs"
+                  <+> pretty a
+
+  for_ vals$ \(v, vs) -> do
+      liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs))
+
+  for_ g $ \git -> do
+    liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
+
+  dbPath <- asks fixmeEnvDbPath >>= readTVarIO
+  liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
+
+  (before,after) <- asks fixmeEnvCatContext >>= readTVarIO
+
+  liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
+
+  ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
+
+  for_ ma $ \(n, syn) -> do
+    liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
+
+

fixme-new/lib/Fixme/RunOld.hs

@@ -1,7 +1,7 @@
 {-# Language MultiWayIf #-}
 {-# Language PatternSynonyms #-}
 {-# Language ViewPatterns #-}
-module Fixme.Run where
+module Fixme.RunOld where
 
 import Prelude hiding (init)
 import Fixme.Prelude hiding (indent)