chore: add filter, sort to library tags

1 files changed, 42 insertions, 87 deletions

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 []
         ]
     )