chore: add filter, sort to library tags

2 files changed, 240 insertions, 27 deletions

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