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)
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 ()
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 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 !! (x1)
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
L.putStrLn $ "Learning: " <> name
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
""
$ \s -> return $ map (\x -> Completion x x False)
$ filter (s `isInfixOf`) cc
type Update = WithSource (Maybe AccountName)
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
$ 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
dbaclProc :: String -> [String]
dbaclProc x = [ "-g" , oneword
, "-g" , twowords
, "-d"
, "-0"
, "-j"
, "-l", x
, "-o", x ++ "_online"
]
where word = "(^|[^[:alpha:]])([[:alpha:]]{3,})"
oneword = wrap $ word ++"||2"
twowords = wrap $ word++"[^[:alpha:]]+"++word++"||24"
wrap = id
dbaclProcC :: [String] -> [String]
dbaclProcC cats = let cats' = concat $ sequence [["-c"],cats]
in ( cats' ++ [
"-n"
] )