voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, delete support

This commit is contained in:
Dmitry Zuikov 2024-09-10 09:03:50 +03:00
parent 9edd820f2e
commit 3db658ab93
3 changed files with 23 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
fixme-new/lib/Fixme/Run.hs
View File

@ -123,8 +123,8 @@ runFixmeCLI m = do
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO builtinAttribs
<*> newTVarIO builtinAttribVals
<*> newTVarIO mempty
<*> newTVarIO defCommentMap
<*> newTVarIO Nothing
@ -317,6 +317,15 @@ runTop forms = do
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "delete" $ nil_ \case
[ FixmeHashLike w ] -> lift do
void $ runMaybeT do
key <- lift (selectFixmeKey w) >>= toMPlus
lift $ modifyFixme key [("deleted", "true")]
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "dump" $ nil_ $ \case
[ FixmeHashLike w ] -> lift $ void $ runMaybeT do
key <- lift (selectFixmeKey w) >>= toMPlus

9
fixme-new/lib/Fixme/State.hs
View File

@ -218,7 +218,7 @@ genPredQ tbl what = go what
let bsql = go b
([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
Ignored -> ("false", mempty)
Ignored -> ("true", mempty)
cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
@ -271,9 +271,8 @@ listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q)
listFixme expr = do
let (w,bound) = genPredQ "s1" (predicate expr)
let end = case bound of
[] -> " or true" :: String
_ -> " or false"
let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
let sql = [qc|
with s1 as (
@ -284,7 +283,7 @@ listFixme expr = do
select s1.blob from s1
where
{w}
{end}
{present}
order by
json_extract(s1.blob, '$.commit-time') asc nulls last,
json_extract(s1.blob, '$.w') asc nulls last

10
fixme-new/lib/Fixme/Types.hs
View File

@ -383,6 +383,12 @@ fixmeGetGitDirCLIOpt = do
<&> fmap (\d -> [qc|--git-dir {d}|])
<&> fromMaybe ""
builtinAttribs :: HashSet FixmeAttrName
builtinAttribs = HS.singleton "deleted"
builtinAttribVals :: HashMap FixmeAttrName (HashSet FixmeAttrVal)
builtinAttribVals = HM.fromList [("deleted", HS.fromList ["true","false"])]
newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
deriving newtype ( Applicative
, Functor
@ -404,8 +410,8 @@ fixmeEnvBare =
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> newTVarIO builtinAttribs
<*> newTVarIO builtinAttribVals
<*> newTVarIO mempty
<*> newTVarIO defCommentMap
<*> newTVarIO Nothing