module Buchhaltung.Uniques
where
import Buchhaltung.Common
import Control.Arrow hiding (loop)
import Control.Monad.RWS.Strict
import Control.Monad.Trans.Cont
import Data.Function
import Data.List
import qualified Data.ListLike as L
import qualified Data.ListLike.String as L
import qualified Data.Map as M
import Data.Ord
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import Data.Time.Calendar
import Formatting as F
import qualified Formatting.ShortFormatters as F
import Hledger.Data
import System.IO
import Text.EditDistance
import qualified Text.PrettyPrint.Boxes as P
import Text.Printf
type M r m = ContT r (RWST () () (M.Map Key Entry) m)
type Key = ([(CommoditySymbol,Quantity)], AccountName, Day, Int)
addNew :: (MonadIO m, MonadReader (Options user Config env) m)
=> [FilledEntry]
-> Journal
-> m [Entry]
addNew newTxs journal = do
tag <- askTag
let g i tx = (key tx i
, ImportedEntry tx () $ wSource <$> extractSource tag tx)
fmap (M.elems . fst)
<$> execRWST (evalContT $ callCC $ \exit -> zipWithM_
(loop exit $ length newTxs) [1..] newTxs)
() $ M.fromList
$ zipWith g [1..] (jtxns journal)
key :: Transaction -> Int -> Key
key tx i = (compAmount $ pamount p, paccount p, tdate tx, i)
where compAmount (Mixed am) = sort
$ fmap (acommodity &&& aquantity) am
p = head $ tpostings tx
loop :: (MonadIO m, MonadReader (Options user Config env) m)
=> (() -> M r m ())
-> Int -> Int -> FilledEntry -> M r m ()
loop exit totalTx iTx new = do
new' <- gets $ \old -> (key (ieT new) $ M.size old + 1, new)
dups <- findDuplicates new'
let msg = format ("Transaction: "%F.d%" of "%F.d%" new\n") iTx totalTx
checkOrAsk exit new' msg
$ sortBy (flip $ comparing snd)
$ (id &&& g) <$> dups
where g (_, y) = negate . on
(restrictedDamerauLevenshteinDistance defaultEditCosts)
(TL.unpack . json) (ieSource new)
<$> (eitherToMaybe $ ieSource y)
eitherToMaybe :: Either b a -> Maybe a
eitherToMaybe = either (const Nothing) Just
findDuplicates :: Monad m => (Key, FilledEntry) -> M r m [(Key,Entry)]
findDuplicates ((ams,acc,day,ix), _) = lift $ gets $ \old ->
let later = snd $ M.split (ams,acc,day,0) old in
M.toList $ fst $ M.split (ams,acc,addDays 1 day,ix) later
checkOrAsk :: (MonadIO m, MonadReader (Options user Config env) m)
=> (() -> M r m ())
-> (Key, FilledEntry)
-> TL.Text
-> [((Key,Entry), Maybe Int)] -> M r m ()
checkOrAsk _ new _ [] = do
modify $ uncurry M.insert $ second fromFilled new
liftIO $ T.putStrLn "\nSaved new transaction.\n"
checkOrAsk exit new msg (( (oldKey,oldEntry), cost):remaining) = do
if cost == Just 0 then return ()
else if False && cost > Just ( 98)
&& on (==) (tdate.ieT) oldEntry (fromFilled $ snd new) then do
overwriteOldSource
else do
let question = (answer =<<) . liftIO $ do
L.putStr $ L.unlines
[ prettyPrint cost (snd new) oldEntry msg $ length remaining
, "Yes, they are duplicates. Update the source [y]"
, "No, " <> (if null remaining then "Save as new transaction"
else "Show next duplicate") <> " [n]"
, "Skip this new transaction [q]"
, "Skip this and all remaining transactions [Q]"
, "Your answer:" ]
hSetBuffering stdin NoBuffering
getChar <* putStrLn ""
answer 'y' = overwriteOldSource
answer 'n' = checkOrAsk exit new msg remaining
answer 'q' = return ()
answer 'Q' = exit ()
answer _ = question
question
where
overwriteOldSource = lift $ do
tag <- lift $ askTag
modify $ M.adjust (applyChanges tag new oldKey) oldKey
liftIO $ T.putStrLn "\nUpdated duplicate's source.\n"
prettyPrint :: Maybe Int -> FilledEntry -> Entry -> TL.Text
-> Int
-> T.Text
prettyPrint cost new old msg remain =
let union2 = f . second unzip . unzip
. M.toList . union
union old = M.mergeWithKey g
(fmap $ flip (,) "<empty>") (fmap $ (,) "<empty>")
old $ sourceToMap $ ieSource new
g _ x y | x == y = Just $ (x, "")
| True = Just $ (x, y)
f (k,(old,new)) = T.pack $ P.render
$ table [20, 25, 25] header [k, old, new]
header = ["Field", "Old", "New"]
oldSource = ieSource old
showError (Left x) = [""
,"Error retrieving old transaction's source:"
, T.pack x]
showError (Right _) = []
def _ Nothing = "n.a."
def f (Just x) = f x
in
L.unlines $
[ union2 . either (const mempty) sourceToMap $ oldSource ]
++ [ sformat
("changes: "%F.s%"/"%F.s%"\n"%F.t%"Remaining existing duplicates: "%F.d)
(def (show . negate) cost)
(def (show . TL.length . json) $ eitherToMaybe $ ieSource old)
msg
remain
]
++ showError oldSource
applyChanges :: ImportTag -> (Key, FilledEntry)
-> Key -> Entry -> Entry
applyChanges tag ((ams2,acc2,day2,_),newEntry)
(ams1, acc1, _, _) oldEntry =
if (ams2,acc2) /= (ams1,acc1) then
error $ unlines ["Change not supported: "
, show newEntry
, show oldEntry]
else oldEntry{ieT= (injectSource tag (ieSource newEntry)
$ ieT oldEntry){tdate = day2}}