From 82d64d4053f47d6263b0faef708dc0c7a905216b Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Thu, 28 Dec 2023 03:23:42 +0100
Subject: chore: add filter, sort to library tags
---
app/Main.hs | 129 ++++++++++++++++++++----------------------------------------
1 file changed, 42 insertions(+), 87 deletions(-)
(limited to 'app')
diff --git a/app/Main.hs b/app/Main.hs
index 0ca099b..41b81d0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -13,7 +13,7 @@
module Main where
-import Control.Arrow (first, second, (***))
+import Control.Arrow (first, second)
import Control.Concurrent.ParallelIO.Local (parallel, withPool)
import Control.Exception (Exception, throw, throwIO)
import Control.Monad (forM, unless, when)
@@ -71,7 +71,7 @@ data Cmd
{ indexNames :: [FilePath]
}
| List
- { filters :: [Filter],
+ { filters :: [G.Filter],
todo :: Bool,
view :: Bool,
redo :: Bool,
@@ -196,63 +196,33 @@ autoArg =
<> O.help "Automatically tag document(s)"
)
-filtersArg :: O.Parser [Filter]
+filtersArg :: O.Parser [G.Filter]
filtersArg =
O.many $
O.option
- (O.maybeReader parse)
+ (O.eitherReader (A.parseOnly G.filterParser . T.pack))
( O.long "filter"
<> O.short 'f'
<> O.help "Filter documents by tag"
)
- where
- parse ('@' : tagKey) = Just (Filter Include (FilterByTag (T.pack tagKey)))
- parse ('!' : '@' : tagKey) = Just (Filter Exclude (FilterByTag (T.pack tagKey)))
- parse _ = Nothing
tagsArg :: O.Parser [G.Tag]
tagsArg =
O.many $
O.option
- (O.maybeReader parse)
+ (O.eitherReader (A.parseOnly G.tagParser . T.pack))
( O.long "tag"
<> O.help "Tag to add"
)
- where
- parse ('@' : tag) =
- let (tagKey, tagValue) =
- T.strip *** T.strip $
- T.break (== ' ') (T.pack tag)
- in Just $
- G.Tag
- tagKey
- ( if T.null tagValue
- then Nothing
- else (Just tagValue)
- )
- parse _ = Nothing
untagsArg :: O.Parser [G.Tag]
untagsArg =
O.many $
O.option
- (O.maybeReader parse)
+ (O.eitherReader (A.parseOnly G.tagParser . T.pack))
( O.long "untag"
<> O.help "Tag to remove"
)
- where
- parse ('@' : tag) =
- let (tagKey, tagValue) =
- T.strip *** T.strip $
- T.break (== ' ') (T.pack tag)
- in Just $
- G.Tag
- tagKey
- ( if T.null tagValue
- then Nothing
- else (Just tagValue)
- )
- parse _ = Nothing
languageArg :: O.Parser (Maybe String)
languageArg =
@@ -300,13 +270,6 @@ viewArg =
<> O.help "Run command `view` on listed document(s)"
)
-data Filter = Filter Mode SimpleFilter
-
-data Mode = Include | Exclude
-
-data SimpleFilter
- = FilterByTag T.Text
-
main :: IO ()
main = do
settings <- S.readSettings
@@ -351,32 +314,32 @@ main = do
printf "%s\n" (takeBaseName doc.iFileName)
printTags doc
)
- . applyFilters filters
+ . filter (G.applyFilters filters . (.index.tags))
=<< getDocuments
Args {cmd = List {filters, redo, edit = True}} -> do
doRedoIf filters redo
editDocuments
- . applyFilters filters
+ . filter (G.applyFilters filters . (.index.tags))
=<< getDocuments
Args {cmd = List {filters, redo, todo = True}} -> do
doRedoIf filters redo
allDocs <- getDocuments
_ <-
processDocumentsInteractively settings allDocs
- . applyFilters filters
+ . filter (G.applyFilters filters . (.index.tags))
$ allDocs
pure ()
Args {cmd = Todo} -> do
allDocs <- getDocuments
_ <-
processDocumentsInteractively settings allDocs
- . applyFilters [Filter Include (FilterByTag "todo")]
+ . filter (G.applyFilters [G.filter G.include "todo" Nothing] . (.index.tags))
$ allDocs
pure ()
Args {cmd = List {filters, redo, view = True}} -> do
doRedoIf filters redo
viewDocuments
- . applyFilters filters
+ . filter (G.applyFilters filters . (.index.tags))
=<< getDocuments
Args {cmd = View {indexNames}} -> do
viewDocuments
@@ -418,11 +381,11 @@ printTags doc =
)
(doc.index.tags `S.union` doc.index.internalTags)
-doRedoIf :: [Filter] -> Bool -> IO ()
+doRedoIf :: [G.Filter] -> Bool -> IO ()
doRedoIf filters redo =
when redo do
parMapM_ doRedo
- . applyFilters filters
+ . filter (G.applyFilters filters . (.index.tags))
=<< getDocuments
where
doRedo doc = do
@@ -456,8 +419,8 @@ tagValues :: [Document] -> M.Map T.Text (S.Set T.Text)
tagValues docs =
M.unionsWith S.union $
mapMaybe
- ( \(G.Tag tagKey tagValue) ->
- M.singleton tagKey . S.singleton <$> tagValue
+ ( \tag ->
+ M.singleton (G.tagKey tag) . S.singleton <$> (G.tagValue tag)
)
(S.toList (S.unions (map (.index.tags) docs)))
@@ -471,20 +434,6 @@ readDocument iFileName =
Document iFileName
<$> decodeFile @Index ("index" </> iFileName)
-applyFilters :: [Filter] -> [Document] -> [Document]
-applyFilters filters = filter (pred filters) `at` (.index.internalTags)
- where
- pred1 (Filter Include filter') = pred1' filter'
- pred1 (Filter Exclude filter') = not . pred1' filter'
- pred1' (FilterByTag tagKey) = G.hasTag (G.Tag tagKey Nothing)
- pred filters = \index -> all ($ index) (map pred1 filters)
-
- at :: ([a] -> [a]) -> (b -> a) -> [b] -> [b]
- at _ _ [] = []
- at g f (x : xs)
- | null (g [f x]) = at g f xs
- | otherwise = x : at g f xs
-
processDocumentsInteractively :: S.Settings -> [Document] -> [Document] -> IO [Document]
processDocumentsInteractively settings allDocs docs =
mapM (uncurry processDocumentInteractively) (zip [1 :: Int ..] docs)
@@ -594,7 +543,7 @@ suggestTags settings allDocs doc = do
nub . catMaybes . map R.matchedText . R.allMatches $
doc.index.originalText
R.*=~ pattern
- pure (G.Tag tagName (Just ""), map (G.Tag tagName . Just) tagValues)
+ pure (G.tag tagName (Just ""), map (G.tag tagName . Just) tagValues)
S.SuggestTagByTags tagName -> do
let tagValues =
-- TODO Cache `probabilityMap`
@@ -617,7 +566,7 @@ suggestTags settings allDocs doc = do
& M.toList
& sortBy (comparing (negate . snd))
& map fst
- pure (G.Tag tagName (Just ""), map (G.Tag tagName) tagValues)
+ pure (G.tag tagName (Just ""), map (G.tag tagName) tagValues)
autoApplySuggestedTags :: [(G.Tag, [G.Tag])] -> [G.Tag]
autoApplySuggestedTags =
@@ -654,7 +603,7 @@ applyTags tags' doc = do
addTags tags (removeTags untags doc)
where
(untags, tags) =
- first (map (\tagKey -> G.Tag tagKey Nothing)) $
+ first (map (\tagKey -> G.tag tagKey Nothing)) $
partitionEithers tags'
addTags :: [G.Tag] -> Document -> Document
@@ -703,21 +652,27 @@ tagDocumentInteractively settings allDocs doc = do
pure doc'
where
tagDocumentInteractively' :: G.Tag -> [G.Tag] -> IO (Either T.Text G.Tag)
- tagDocumentInteractively' tag@(G.Tag tagKey Nothing) _ = do
- choice <-
- P.prompt $
- P.choice (printf "tag with %s?" tagKey) (("n" :: String) N.:| ["y"])
- pure $ if (choice == "y") then Right tag else Left tagKey
- tagDocumentInteractively' (G.Tag tagKey (Just _)) tags = do
- tagValue <-
- fmap T.pack . P.prompt $
- P.string
- (printf "tag with %s?" tagKey)
- (mapMaybe (fmap T.unpack . G.tagValue) tags ++ ["-"])
- pure $
- if tagValue == "-"
- then Left tagKey
- else Right (G.Tag tagKey (Just tagValue))
+ tagDocumentInteractively' tag tags
+ | Nothing <- G.tagValue tag = do
+ choice <-
+ P.prompt $
+ P.choice
+ (printf "tag with %s?" (G.tagKey tag))
+ (("n" :: String) N.:| ["y"])
+ pure $
+ if (choice == "y")
+ then Right tag
+ else Left (G.tagKey tag)
+ | Just _ <- G.tagValue tag = do
+ tagValue <-
+ fmap T.pack . P.prompt $
+ P.string
+ (printf "tag with %s?" (G.tagKey tag))
+ (mapMaybe (fmap T.unpack . G.tagValue) tags ++ ["-"])
+ pure $
+ if tagValue == "-"
+ then Left (G.tagKey tag)
+ else Right tag
ensureGit :: IO ()
ensureGit = do
@@ -849,10 +804,10 @@ internalTags :: Index -> S.Set G.Tag
internalTags index =
S.fromList
( concat
- [ [ G.Tag "addedAt" (Just (T.pack (iso8601Show index.addedAt))),
- G.Tag "language" (Just (T.pack index.language))
+ [ [ G.tag "addedAt" (Just (T.pack (iso8601Show index.addedAt))),
+ G.tag "language" (Just (T.pack index.language))
],
- if index.todo then [G.Tag "todo" Nothing] else []
+ if index.todo then [G.tag "todo" Nothing] else []
]
)
--
cgit v1.2.3