diff --git a/.fixme-new/config b/.fixme-new/config index 6842955e..b93d67ca 100644 --- a/.fixme-new/config +++ b/.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 - - diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index b13aa4b6..9dc380b6 100644 --- a/fixme-new/fixme.cabal +++ b/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 diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index d36255c7..821bf6c8 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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 diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs new file mode 100644 index 00000000..4b670f6f --- /dev/null +++ b/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) + + diff --git a/fixme-new/lib/Fixme/RunOld.hs b/fixme-new/lib/Fixme/RunOld.hs index ff538f38..ed2e0888 100644 --- a/fixme-new/lib/Fixme/RunOld.hs +++ b/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)