diff options
| -rw-r--r-- | apaperless.cabal | 6 | ||||
| -rw-r--r-- | app/Main.hs | 197 | ||||
| -rw-r--r-- | app/Prompt.hs | 85 |
3 files changed, 177 insertions, 111 deletions
diff --git a/apaperless.cabal b/apaperless.cabal index 141a710..c9a61cb 100644 --- a/apaperless.cabal +++ b/apaperless.cabal @@ -19,7 +19,8 @@ common warnings executable apaperless import: warnings main-is: Main.hs - -- other-modules: + other-modules: + Prompt -- other-extensions: build-depends: base, @@ -38,6 +39,7 @@ executable apaperless lock-file, data-default, tags, - time + time, + regex hs-source-dirs: app default-language: GHC2021 diff --git a/app/Main.hs b/app/Main.hs index cb6e563..d10e407 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoFieldSelectors #-} @@ -19,7 +20,9 @@ import Data.Attoparsec.Text qualified as A import Data.ByteString.Lazy qualified as LB import Data.Default import Data.Digest.Pure.SHA (sha256, showDigest) +import Data.Function ((&)) import Data.List +import Data.List.NonEmpty qualified as N import Data.Map qualified as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Set qualified as S @@ -34,15 +37,16 @@ import GHC.Conc (getNumProcessors) import GHC.Generics (Generic) import GHC.Records (HasField (..)) import Options.Applicative qualified as O +import Prompt qualified as P import System.Directory import System.Environment (getEnv) import System.FilePath -import System.IO import System.IO.LockFile (withLockFile) import System.IO.Temp (withSystemTempDirectory) import System.Process.Typed import Tag import Text.Printf (printf) +import Text.RE.TDFA.Text qualified as R import Text.Read (readMaybe) data Args = Args @@ -52,7 +56,9 @@ data Args = Args data Cmd = Consume { keep :: Bool, - inputs :: [FilePath] + inputs :: [FilePath], + prompt :: Bool, + force :: Bool } | Edit { indexNames :: [FilePath] @@ -93,6 +99,8 @@ consumeCmd = Consume <$> keepArg <*> inputsArg + <*> promptArg + <*> forceArg editCmd :: O.Parser Cmd editCmd = @@ -130,9 +138,26 @@ keepArg :: O.Parser Bool keepArg = O.switch ( O.long "keep" + <> O.short 'k' <> O.help "Keep input document" ) +promptArg :: O.Parser Bool +promptArg = + O.switch + ( O.long "prompt" + <> O.short 'p' + <> O.help "Prompt after consuming document(s)" + ) + +forceArg :: O.Parser Bool +forceArg = + O.switch + ( O.long "force" + <> O.short 'f' + <> O.help "Force operation, overriding safety checks" + ) + filtersArg :: O.Parser [Filter] filtersArg = O.many $ @@ -194,9 +219,11 @@ main = do ensureDir "index" O.execParser (O.info (args O.<**> O.helper) O.idm) >>= \case - Args {cmd = Consume {keep, inputs}} -> - mapM_ putStrLn - =<< parMapM (consume1 keep) (map (cwd </>) inputs) + Args {cmd = Consume {keep, inputs, force}} -> do + indexNames <- parMapM (consume1 force keep) (map (cwd </>) inputs) + documents <- mapM (readDocument . (<.> "json")) indexNames + processDocuments documents + mapM_ putStrLn indexNames Args {cmd = Edit {indexNames}} -> do editDocuments =<< mapM (readDocument . (<.> "json")) indexNames @@ -291,35 +318,40 @@ applyFilters filters = filter (pred filters) `at` (.index.internalTags) processDocuments :: [Document] -> IO () processDocuments docs = - mapM_ (uncurry processDocuments') (zip [1 :: Int ..] docs) + mapM_ (uncurry processDocument) (zip [1 :: Int ..] docs) where numDocs = length docs tagValues' = tagValues docs - processDocuments' n (doc@Document {iFileName, index}) = do + processDocument n (doc@Document {iFileName, index}) = do choice <- - promptChoiceHelp - [ ("f", "view full text"), - ("p", "process document"), - ("s", "skip document"), - ("v", "view document") - ] - ( printf - "%s\n%s\n\n(%d/%d) Process this document?" - (takeBaseName iFileName) - index.shortText - n - numDocs + P.prompt + ( P.choice + ( printf + "%s\n%s\n\n(%d/%d) Process this document?" + (takeBaseName iFileName) + index.shortText + n + numDocs + ) + (("f" :: String) N.:| ["p", "s", "v"]) + & P.help + ( \a -> case a of + "f" -> "view full text" + "p" -> "process document" + "s" -> "skip document" + "v" -> "view document" + ) ) case choice of "f" -> do printf "%s\n" (takeBaseName doc.iFileName) printf "%s\n" doc.index.originalText - processDocuments' n doc - "p" -> processDocument tagValues' doc + processDocument n doc + "p" -> tagDocument tagValues' doc "s" -> pure () "v" -> do viewDocuments [doc] - processDocuments' n doc + processDocument n doc viewDocuments :: [Document] -> IO () viewDocuments docs = @@ -357,101 +389,47 @@ editDocuments docs = ) docs -processDocument :: M.Map T.Text (S.Set T.Text) -> Document -> IO () -processDocument tagValues (Document {iFileName, index}) = do - printf "%s\n" index.originalText +tagDocument :: M.Map T.Text (S.Set T.Text) -> Document -> IO () +tagDocument tagValues (Document {iFileName, index}) = do + let createdAts = + nub . catMaybes . map R.matchedText . R.allMatches $ + index.originalText + R.*=~ [R.re|[0-9]{2}\.[0-9]{2}\.[0-9]{4}|] let suggestedTags = - [ Tag "correspondent" (Just ""), - Tag "invoice" Nothing, - Tag "bill" Nothing + [ ( Tag "createdAt" (Just ""), + map (Tag "createdAt" . Just) createdAts + ) + {-, + Tag "correspondent" (Just ""), + Tag "invoice" Nothing, + Tag "bill" Nothing-} ] tags <- S.fromList . catMaybes - <$> mapM (processSuggestedTag tagValues) suggestedTags + <$> mapM (uncurry tagDocument') suggestedTags let tags' = S.delete (Tag "todo" Nothing) (index.tags `S.union` tags) index' = index {tags = tags'} iFilePath = "index" </> iFileName withGit do J.encodeFile iFilePath index' commitAll [iFilePath] (printf "process %s (interactive)" iFilePath) - -processSuggestedTag :: M.Map T.Text (S.Set T.Text) -> Tag -> IO (Maybe Tag) -processSuggestedTag _ tag@(Tag tagKey Nothing) = do - choice <- promptChoice (Just "n") ["n", "y"] (printf "tag with %s?" tagKey) - pure $ if (choice == "y") then Just tag else Nothing -processSuggestedTag tagValues (Tag tagKey (Just _)) = do - tagValue <- - promptString - (maybe [] S.toList (M.lookup tagKey tagValues)) - (printf "tag with %s?" tagKey) - pure $ - if not (T.null tagValue) - then Just (Tag tagKey (Just tagValue)) - else Nothing - -promptChoice :: Maybe T.Text -> [T.Text] -> String -> IO T.Text -promptChoice mDef as s = do - a <- - T.toLower - <$> promptString - [] - ( s - ++ ( T.unpack - ( " [" - <> T.intercalate "" (map capitalizeDef as) - <> "]" - ) - ) - ) - case (a, mDef) of - ("", Just def) -> pure def - _ -> - if not (T.toLower a `elem` map T.toLower as) - then promptChoice mDef as s - else pure a where - capitalizeDef a = (if Just a == mDef then T.toUpper else T.toLower) a - -promptChoiceHelp :: [(T.Text, T.Text)] -> String -> IO T.Text -promptChoiceHelp as' s = do - a <- - T.toLower - <$> promptString - [] - ( s - ++ ( T.unpack - (" [" <> T.intercalate "" (as ++ ["?"]) <> "]") - ) - ) - if a == "?" - then do - printHelp - promptChoiceHelp as' s - else - if not (T.toLower a `elem` map T.toLower as) - then promptChoiceHelp as' s - else pure a - where - as = map fst as' - printHelp = mapM_ (uncurry (printf "%s - %s\n")) as' - -promptString :: [T.Text] -> String -> IO T.Text -promptString as s = do - if null as - then do - putStr (s <> "> ") - else do - putStrLn s - mapM_ (\(n, a) -> printf "[%d] %s\n" n a) (zip [1 :: Int ..] as) - putStr "> " - hFlush stdout - a <- T.strip <$> T.getLine - case (as, readMaybe (T.unpack a)) of - ((_ : _), Just n) -> - case drop (n - 1) as of - [] -> promptString as s - (a' : _) -> pure a' - _ -> pure a + tagDocument' :: Tag -> [Tag] -> IO (Maybe Tag) + tagDocument' tag@(Tag tagKey Nothing) tags = do + choice <- + P.prompt $ + P.choice (printf "tag with %s?" tagKey) (("n" :: String) N.:| ["y"]) + pure $ if (choice == "y") then Just tag else Nothing + tagDocument' (Tag tagKey (Just _)) tags = do + tagValue <- + fmap T.pack . P.prompt $ + P.string + (printf "tag with %s?" tagKey) + (map T.unpack $ mapMaybe tagValue tags) + pure $ + if not (T.null tagValue) + then Just (Tag tagKey (Just tagValue)) + else Nothing ensureGit :: IO () ensureGit = do @@ -468,14 +446,15 @@ debug s x = fileKey :: FilePath -> IO FilePath fileKey filePath = + -- TODO Use `sha1` instead of `sha256` showDigest . sha256 <$> LB.readFile filePath -consume1 :: Bool -> FilePath -> IO FilePath -consume1 keep filePath = do +consume1 :: Bool -> Bool -> FilePath -> IO FilePath +consume1 force keep filePath = do fKey <- fileKey filePath let oFilePath = "originals" </> fKey <.> takeExtension filePath originalExists <- doesFileExist oFilePath - when originalExists do + when (originalExists && not force) do error (printf "error: error adding %s: duplicate of %s\n" filePath oFilePath) let iFilePath = "index" </> fKey <.> "json" originalText <- do diff --git a/app/Prompt.hs b/app/Prompt.hs new file mode 100644 index 0000000..0548c80 --- /dev/null +++ b/app/Prompt.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Prompt + ( Prompt, + prompt, + choice, + string, + help, + compact, + ) +where + +import Data.Char (isSpace) +import Data.List.NonEmpty qualified as N +import Data.Maybe (fromJust, isNothing) +import System.IO (hFlush, stdout) +import Text.Printf (printf) +import Text.Read (readMaybe) + +data Prompt a where + Choice :: Bool -> Maybe (a -> String) -> String -> N.NonEmpty a -> Prompt a + String :: Bool -> Maybe (String -> String) -> String -> [String] -> Prompt String + +string :: String -> [String] -> Prompt String +string = String False Nothing + +choice :: String -> N.NonEmpty a -> Prompt a +choice = Choice False Nothing + +-- TODO add `help` +help :: (a -> String) -> Prompt a -> Prompt a +help h (Choice c _ q as) = Choice c (Just h) q as +help h (String c _ q as) = String c (Just h) q as + +-- TODO add `compact` +compact :: Prompt a -> Prompt a +compact (Choice _ h' q as) = Choice True h' q as +compact (String _ h' q as) = String True h' q as + +class Promptable a where + toString :: a -> String + fromString :: String -> Maybe a + +instance Promptable String where + toString = id + fromString = Just + +prompt :: (Eq a, Promptable a) => Prompt a -> IO a +prompt p@(Choice c h' q as) = do + -- TODO add `help` + let p' = String c Nothing q (map toString (N.toList as)) + a' <- fromString <$> prompt p' + if isNothing a' || not (a' `elem` (map Just (N.toList as))) + then prompt p + else pure (fromJust a') +prompt p@(String _ _ q as) = do + if null as + then printf "%s " q + else do + printf "%s\n" q + mapM_ (\(n, a) -> printf "[%d] %s\n" n a) (zip [1 :: Int ..] as) + printf "Your choice? [default: %s] " (head as) + hFlush stdout + a <- strip <$> getLine + if null as + then pure a + else case readMaybe a of + Just n -> + case drop (n - 1) as of + [] -> prompt p + (a : _) -> pure a + Nothing -> + if null a + then pure (head as) + else pure a + +strip :: String -> String +strip = stripEnd . stripStart + +stripStart :: String -> String +stripStart = dropWhile isSpace + +stripEnd :: String -> String +stripEnd = reverse . stripStart . reverse |