mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
440ad2b415
commit
0d5d035fb6
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -104,6 +104,9 @@ common shared-properties
|
|||
library
|
||||
import: shared-properties
|
||||
|
||||
other-modules:
|
||||
Fixme.Run.Internal
|
||||
|
||||
exposed-modules:
|
||||
Fixme
|
||||
Fixme.Config
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue