path: root/tags/src/Tag.hs

module Tag
  ( -- * Tag data-type
    Tag,
    tag,
    tagKey,
    tagValue,

    -- ** 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 Control.DeepSeq (NFData (rnf))
import Data.Aeson qualified as J
import Data.Attoparsec.Text qualified as A
import Data.Binary (Binary)
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 qualified as T
import GHC.Generics (Generic)
import Text.RE.TDFA.Text qualified as R
import TypedValue (cast, castDef)

data Tag = Tag T.Text (Maybe T.Text)
  deriving (Show, Generic, Binary, Eq, Ord)

instance NFData Tag where
  rnf (Tag k v) = rnf k `seq` rnf v

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 -> T.Text
tagKey (Tag k _) = k

tagKeyParser :: A.Parser T.Text
tagKeyParser =
  A.string "@" *> A.takeWhile1 (/= ' ')

tagValue :: Tag -> Maybe T.Text
tagValue (Tag _ v) = v

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)