diff options
Diffstat (limited to 'tags/src')
| -rw-r--r-- | tags/src/Tag.hs | 253 |
1 files changed, 234 insertions, 19 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) |