chore: add filter, sort to library tags

3 files changed, 282 insertions, 114 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 []
         ]
     )
 
diff --git a/tags/src/Tag.hs b/tags/src/Tag.hs
index ab7e171..f7f3398 100644
--- a/tags/src/Tag.hs
+++ b/tags/src/Tag.hs
@@ -1,41 +1,256 @@
 module Tag
-  ( Tag (..),
+  ( -- * Tag data-type
+    Tag,
+    tag,
     tagKey,
     tagValue,
-    hasTag,
+
+    -- ** Tag-related parsers
+    tagParser,
+    tagKeyParser,
+    tagValueParser,
+
+    -- * Tag operators
+    has,
+    member,
+    insert,
+    delete,
+    deleteAll,
+    replace,
     tagValuesOf,
+
+    -- * Filtering by tag
+    Filter,
+    Tag.filter,
+    Mode,
+    include,
+    exclude,
+    Test,
+    eq,
+    ge,
+    gt,
+    le,
+    lt,
+    match,
+    applyFilters,
+
+    -- ** Filter-related parsers
+    filterParser,
+
+    -- * Sorting by tag
+    Sort,
+    sort,
+    Order,
+    asc,
+    desc,
+    applySorts,
+
+    -- ** Sort-related parser
+    sortParser,
   )
 where
 
+import Control.Applicative ((<|>))
 import Data.Aeson qualified as J
+import Data.Attoparsec.Text qualified as A
 import Data.Binary (Binary)
-import Data.Maybe (mapMaybe)
+import Data.Function (on)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Set qualified as S
-import Data.Text (Text)
+import Data.Text qualified as T
 import GHC.Generics (Generic)
+import Text.RE.TDFA.Text qualified as R
+import TypedValue (cast, castDef)
 
-data Tag = Tag Text (Maybe Text)
+data Tag = Tag T.Text (Maybe T.Text)
   deriving (Show, Generic, Binary, Eq, Ord)
 
+tag :: T.Text -> Maybe T.Text -> Tag
+tag = Tag
+
+tagParser :: A.Parser Tag
+tagParser =
+  Tag
+    <$> (tagKeyParser <* A.skipSpace)
+    <*> (A.try (Just <$> tagValueParser) <|> pure Nothing)
+
 instance J.FromJSON Tag
 
 instance J.ToJSON Tag
 
-tagKey :: Tag -> Text
+tagKey :: Tag -> T.Text
 tagKey (Tag k _) = k
 
-tagValue :: Tag -> Maybe Text
+tagKeyParser :: A.Parser T.Text
+tagKeyParser =
+  A.string "@" *> A.takeWhile1 (/= ' ')
+
+tagValue :: Tag -> Maybe T.Text
 tagValue (Tag _ v) = v
 
-hasTag :: Tag -> S.Set Tag -> Bool
-hasTag tag =
-  (tagKey tag `S.member`) . S.map tagKey
-
-tagValuesOf :: Text -> [Tag] -> [Text]
-tagValuesOf key =
-  mapMaybe
-    ( \tag ->
-        if tagKey tag == key
-          then tagValue tag
-          else Nothing
-    )
+tagValueParser :: A.Parser T.Text
+tagValueParser =
+  T.pack <$> A.many1 A.anyChar
+
+has :: T.Text -> S.Set Tag -> Bool
+has k =
+  (k `S.member`) . S.map tagKey
+
+member :: Tag -> S.Set Tag -> Bool
+member =
+  S.member
+
+insert :: Tag -> S.Set Tag -> S.Set Tag
+insert = S.insert
+
+delete :: Tag -> S.Set Tag -> S.Set Tag
+delete = S.delete
+
+deleteAll :: T.Text -> S.Set Tag -> S.Set Tag
+deleteAll k = S.filter ((/= k) . tagKey)
+
+replace :: Tag -> S.Set Tag -> S.Set Tag
+replace t = insert t . deleteAll (tagKey t)
+
+tagValuesOf :: T.Text -> S.Set Tag -> S.Set T.Text
+tagValuesOf k =
+  S.fromList . mapMaybe tagValue . S.toList . S.filter ((== k) . tagKey)
+
+data Filter = Filter Mode T.Text (Maybe Test)
+
+filter :: Mode -> T.Text -> Maybe Test -> Filter
+filter = Filter
+
+filterParser :: A.Parser Filter
+filterParser =
+  Filter
+    <$> modeParser
+    <*> (tagKeyParser <* A.skipSpace)
+    <*> (A.try (Just <$> testParser) <|> pure Nothing)
+
+data Mode = Include | Exclude
+
+include, exclude :: Mode
+include = Include
+exclude = Exclude
+
+modeParser :: A.Parser Mode
+modeParser = (const Exclude <$> A.string "!") <|> (pure Include)
+
+data Test
+  = Eq T.Text
+  | Ge T.Text
+  | Gt T.Text
+  | Le T.Text
+  | Lt T.Text
+  | Match R.RE
+
+eq, ge, gt, le, lt :: T.Text -> Test
+eq = Eq
+ge = Ge
+gt = Gt
+le = Le
+lt = Lt
+
+match :: R.RE -> Test
+match = Match
+
+testParser :: A.Parser Test
+testParser =
+  A.choice
+    [ A.try (A.string "/" *> (Match <$> reParser) <* A.string "/"),
+      A.try (A.string ">=" *> (Ge <$> value)),
+      A.try (A.string "<=" *> (Le <$> value)),
+      A.try (A.string ">" *> (Gt <$> value)),
+      A.try (A.string "<" *> (Lt <$> value)),
+      (Eq <$> value)
+    ]
+  where
+    value = T.pack <$> A.many1 A.anyChar
+
+    reParser :: A.Parser R.RE
+    reParser =
+      R.compileRegex . T.unpack . T.concat
+        =<< A.many'
+          ( A.choice
+              [ A.string "\\/" *> A.string "/",
+                A.string "\\" *> A.string "\\",
+                T.pack . (: []) <$> A.notChar '/'
+              ]
+          )
+
+applyFilters :: [Filter] -> S.Set Tag -> Bool
+applyFilters fs ts =
+  all (flip applyFilter ts) fs
+
+applyFilter :: Filter -> S.Set Tag -> Bool
+applyFilter (Filter Exclude k v') ts =
+  not (applyFilter (Filter Include k v') ts)
+applyFilter (Filter Include k v') ts =
+  any ((&&) <$> matchKey <*> matchValue) ts
+  where
+    matchKey = (==) k . tagKey
+    matchValue t =
+      case (v', tagValue t) of
+        (Just (Eq v), Just w) -> castDef False (==) w v
+        (Just (Ge v), Just w) -> castDef False (>=) w v
+        (Just (Gt v), Just w) -> castDef False (>) w v
+        (Just (Le v), Just w) -> castDef False (<=) w v
+        (Just (Lt v), Just w) -> castDef False (<) w v
+        (Just (Match p), Just w) -> R.matched (w R.?=~ p)
+        (Just _, Nothing) -> False
+        (Nothing, _) -> True
+
+data Sort = Sort Order T.Text
+
+sort :: Order -> T.Text -> Sort
+sort = Sort
+
+sortParser :: A.Parser Sort
+sortParser =
+  Sort <$> orderParser <*> tagKeyParser
+
+data Order
+  = Asc
+  | Desc
+
+orderParser :: A.Parser Order
+orderParser =
+  (A.string "!" *> pure Desc)
+    <|> pure Asc
+
+asc, desc :: Order
+asc = Asc
+desc = Desc
+
+applySorts :: N.NonEmpty Sort -> S.Set Tag -> S.Set Tag -> Ordering
+applySorts = foldr1 compose . map toCompare . N.toList
+  where
+    compose ::
+      (a -> a -> Ordering) ->
+      (a -> a -> Ordering) ->
+      (a -> a -> Ordering)
+    compose f g x y =
+      case f x y of
+        EQ -> g x y
+        r -> r
+
+    toCompare :: Sort -> (S.Set Tag -> S.Set Tag -> Ordering)
+    toCompare (Sort Desc k) = flip $ toCompare (Sort Asc k)
+    toCompare (Sort Asc k) =
+      compareList
+        (incomparableFirst (cast compare))
+        `on` (S.toList . tagValuesOf k)
+
+    compareList :: (a -> a -> Ordering) -> ([a] -> [a] -> Ordering)
+    compareList _ [] _ = LT
+    compareList _ _ [] = GT
+    compareList g (a : as) (b : bs)
+      | g a b == EQ = compareList g as bs
+      | otherwise = g a b
+
+    incomparableFirst ::
+      (a -> a -> Maybe Ordering) ->
+      (a -> a -> Ordering)
+    incomparableFirst cmp a b = fromMaybe LT (cmp a b)
diff --git a/tags/tags.cabal b/tags/tags.cabal
index c78b2c6..0149e74 100644
--- a/tags/tags.cabal
+++ b/tags/tags.cabal
@@ -11,26 +11,23 @@ maintainer:         aforemny@posteo.de
 category:           Data
 build-type:         Simple
 extra-doc-files:    CHANGELOG.md
--- extra-source-files:
-
-common warnings
-    ghc-options: -Wall
 
 library
-    import:           warnings
+    ghc-options: -Wall
     exposed-modules:
       Tag
+    other-modules:
       TypedValue
-    -- other-modules:
-    -- other-extensions:
     build-depends:
       aeson,
+      attoparsec,
       base,
       binary,
       containers,
+      regex,
       text,
       time
-    hs-source-dirs:   src
+    hs-source-dirs: src
     default-language: GHC2021
     default-extensions:
       DeriveAnyClass
@@ -38,3 +35,4 @@ library
       ImportQualifiedPost
       LambdaCase
       OverloadedRecordDot
+      OverloadedStrings