{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK ignore-exports #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Buchhaltung.Match where import Buchhaltung.Ask import Buchhaltung.Common import Buchhaltung.Importers import Buchhaltung.Zipper import Control.Arrow import Control.Concurrent.Async import Control.Lens import Control.Monad.RWS import Control.Monad.Reader import Data.Either import Data.Function import Data.List import qualified Data.List.NonEmpty as N import qualified Data.ListLike as L import qualified Data.ListLike.String as L import qualified Data.Map.Strict as M import Data.Maybe import Data.Ord import qualified Data.Semigroup as S import qualified Data.Set as S import qualified Data.Text as T import Hledger.Data hiding (at) import System.Console.Haskeline import System.Exit import System.FilePath import System.Process import qualified Text.PrettyPrint.Boxes as P import Text.Printf type MatchT m = RWST (FullOptions FilePath) () (M.Map AccountName Bool, Zipper Update) (ErrorT m) -- ^ R: temporaray dbacl path -- -- W: Set of learned accounts -- -- S: Zipper with all transaction that neede to be matched match :: FullOptions FilePath -> Journal -> ErrorT IO () match options j = maybe (liftIO $ print "No unmatched transactions") g $ runReader (groupByAccount j) options where g (done, todos) = void $ runRWST (learn done >> mainLoop "") options (mempty, differentiate todos) :: ErrorT IO () -- | Apply the first matching 'Todo' updateAccountName :: Update -> Maybe (Transaction, Transaction) updateAccountName WithSource{ wInfo = Nothing } = Nothing updateAccountName up = Just (wTx up, tPosts . ix (wIdx up) . pAcc .~ (fromJust $ wInfo up) $ wTx up) printSource :: Source -> String printSource = P.render . table [25,35] ["Field", "Value"] . (\(x,z) -> [x,z]) . unzip . M.toList . sourceToMap mainLoop :: String -> MatchT IO () mainLoop msg = do zip <- gets $ snd let tx = present zip liftIO $ do putStrLn $ printSource $ wSource $ tx printf "Current Transaction: %d, Remaining: %d\n" (length $ past zip ) $ length $ future zip putStr msg account <- myAskAccount =<< suggestAccount tx -- let next = modify (second fwd) >> mainLoop (fwdMsg zip) prev = modify (second back) >> mainLoop (backMsg zip) fwdMsg (LZ _ []) = "<< DONE! Use 'save' to exit >>\n\n" fwdMsg _ = "" backMsg (LZ (_ :| []) _) = "<< This is the first transaction >>\n\n" backMsg _ = "" g "save" = void $ saveChanges Nothing $ changeTransaction $ mapMaybe updateAccountName $ integrate zip g "<" = prev g ">" = next g _ = do learn [(account, return tx)] modify $ second $ modifyPresent (fmap $ const $ Just account) next g account histfsuf :: String histfsuf = "learn" -- | Data type describing the suggested or 'default' account when -- asking the user for account input data Default = Default { prefixed :: T.Text, defAcc :: AccountName } suggestAccount :: Update -> MatchT IO (Maybe Default) suggestAccount tx = do accs <- getAccountList $ id args <- dbaclProcC <$> mapM tmp accs text <- bayesLine tx bin <- readConfig cDbaclExecutable let g = if null accs || T.null text then return Nothing else do (code, output, _) <- liftIO $ readProcessWithExitCode bin args $ T.unpack text case code of ExitSuccess -> return Nothing ExitFailure x -> return $ Just $ Default info sa where sa = accs !! (x-1) info :: T.Text info = either fshow (text . lookup sa) (dbacl_parse accs output) text Nothing = "failed\t\t" text (Just te) = "uncertainty: " <> T.pack te <> "\t" maybe g (return . Just . Default "manual:\t\t\t") $ wInfo tx bayesLine :: Monad m => WithSource a -> MatchT m T.Text bayesLine w = T.strip . T.unwords <$> getBayesFields (wSource w) learn :: [(AccountName, NonEmpty (WithSource a))] -> MatchT IO () learn pairs = do accs <- liftIO . runConcurrently . sequenceA =<< mapM learn' pairs forM_ accs $ \(k,v) -> modify $ first $ M.insertWith const k v where learn' (name,txs) = do bin <- readConfig cDbaclExecutable text <- (L.unlines . filter (not . T.null)) <$> mapM bayesLine (N.toList txs) file <- tmp name let action = if T.null text then return (name, False) else do -- let text = if text'=="" then "\n" else text' PROBLEM-bayes_fields L.putStrLn $ "Learning: " <> name -- putStrLn $ "\n\n"++ (intercalate "\n\n" $ info <$> todos) -- putStrLn text let texts = T.unpack text (code, out, err) <- readProcessWithExitCode bin (dbaclProc file) texts appendFile (file <> "_raw" ) $ texts <> "\n\n" <> out <> "\n\nStd error:\n" <> err let success = code == ExitSuccess && null err L.putStrLn $ if success then "Done: " <> name else "Failed: " <> name <> "\nwith Code "<> fshow code <> "\n\nAnd error:\n" <> T.pack err return (name, success) return $ Concurrently $ action accountCompletion :: [String] -> CompletionFunc IO accountCompletion cc = completeWord Nothing "" -- don't break words on whitespace, since account names -- can contain spaces. $ \s -> return $ map (\x -> Completion x x False) $ filter (s `isInfixOf`) cc type Update = WithSource (Maybe AccountName) -- | Group all transactions with source into those that already have -- an account (ignoring those in 'ignoredAccountsOnMatch') and those -- that start with 'cTodoAccount' -- -- returns `Nothing` if there are no todo transactions groupByAccount :: MonadReader (Options User Config env) m => Journal -> m (Maybe ( [(AccountName, NonEmpty (WithSource ()))] , NonEmpty Update)) groupByAccount j = do ignored <- readUser ignoredAccountsOnMatch tag <- askTag todoFilt <- askTodoFilter let acc = paccount . wPosting f s = if todoFilt ac then Right $ fmap (const Nothing) <$> s else Left (ac, s) where ac = acc $ N.head s return -- combine all transactions with different todo accounts $ traverse (fmap S.sconcat . nonEmpty) $ first (filter $ not . isIgnored ignored . fst) $ partitionEithers $ fmap f $ N.groupBy ((==) `on` acc) $ sortBy (comparing acc) $ rights $ extractSource tag <$> jtxns j myAskAccount :: Maybe Default -> MatchT IO AccountName myAskAccount acc = getAccountList (const True) >>= \accs -> do revAccount <- askReverseAccount let prompt = Right $ T.unlines ["" ,maybe "" ((<> "\n\nHit 'Enter' to use the above account, or") . showdef) acc ,"enter one of the following: account name (in reverse notation), "<> "'<', '>' to navigate, or 'save'"] showdef (Default d a) = d <> (revAccount a) :: T.Text askAccount accs (defAcc <$> acc) (Just histfsuf) prompt getAccountList :: Monad m => (Bool -> Bool) -> MatchT m [AccountName] getAccountList f = gets $ M.keys . M.filter f . fst tmp :: Monad m => T.Text -> MatchT m FilePath tmp name = reader $ ( T.unpack name) . oEnv -- * dbacl arguments -- | learning dbaclProc :: String -> [String] dbaclProc x = [ "-g" , oneword , "-g" , twowords --,"-D" -- interessant "-D" zeigt welche features gefunden wurden (use grep match) , "-d" -- ,"-w 1" -- use N-grams with N=2 -- "-S" -- ignore line breaks , "-0" -- do not preload (this is done by -o) -- ,"-e", "alnum" -- alpha numeric , "-j" -- lowercase , "-l", x , "-o", x ++ "_online" ] -- category name where word = "(^|[^[:alpha:]])([[:alpha:]]{3,})" oneword = wrap $ word ++"||2" twowords = wrap $ word++"[^[:alpha:]]+"++word++"||24" wrap = id --x = "'"++x++"'" -- | classification dbaclProcC :: [String] -> [String] dbaclProcC cats = let cats' = concat $ sequence [["-c"],cats] in ( cats' ++ [ -- search this file for 'debugging' -- "-v" -- output name of best (dont know when useful) "-n" -- neg. logaritm -- , "-N" -- prob -- ,"-X" -- ,"-d" -- sehr hilfreich, see manual (aber nur mit weniger categorien ] )