From 82d64d4053f47d6263b0faef708dc0c7a905216b Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 28 Dec 2023 03:23:42 +0100 Subject: chore: add filter, sort to library tags --- app/Main.hs | 129 ++++++++++------------------- tags/src/Tag.hs | 253 +++++++++++++++++++++++++++++++++++++++++++++++++++----- tags/tags.cabal | 14 ++-- 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 -- cgit v1.2.3