{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK ignore-exports #-} module Buchhaltung.Add (add) where import Buchhaltung.Ask import Buchhaltung.Common import Buchhaltung.ZipEdit2 as ZE import Buchhaltung.Zipper import Control.Applicative import Control.Arrow import Control.Monad.RWS.Strict import Data.Bits import Data.Char import Data.Decimal import Data.Default import Data.Either import Data.Foldable import Data.Function import qualified Data.HashMap.Strict as HM import Data.List import qualified Data.List.NonEmpty as E import qualified Data.ListLike as L import qualified Data.ListLike.String as L import qualified Data.Map as M import Data.Maybe import Data.Monoid ((<>)) import Data.Ord import qualified Data.Set as S import Data.String import qualified Data.Text as T import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Void import Formatting (sformat, (%), (%.)) import qualified Formatting as F import qualified Formatting.ShortFormatters as F import Hledger hiding (at) import Safe import qualified Text.Megaparsec as MP import Text.Parsec.Char import Text.Parsec.Combinator (eof,many1) import Text.Parsec.Prim (parse,try) import Text.Parsec.String import Text.Printf import Text.Read (readEither) -- DONE: clear an entry without entering a new one -- TODO: percentage entry with memory -- TODO: other ways to find uncleared transactions (e.g. by account) -- DONE cancel unsuccesful search (and do ot force start of transaction entry) -- TODO: do not propose transfer accounts? -- TODO: change (existing) titles to include account -- TODO: insert assertions? (for geldbeutetl or automatic for hbci) -- TODO: check assertions (gegenseitige schulden) -- TODO: do not jump to next suggestion (only after half) -- TODO: betrag vorschlagen mit history? oder siehen nächstes -- TODO: möglichenkeiten der eingabe von beträgen für beide parteien gleichzeitig -- TODO: keine kontonamen in falscher reihenfolge vorschlagen -- DONE in 8fbbc34: BUG: discard stil marks as cleared -- * Types type UserJournals = M.Map Username Journal type AddT' env m = RWST (FullOptions env) () UserJournals (ErrorT m) -- | Monad Transformer used to describe the 'add' program -- -- The 'add' specific environment, that can contain a partner user type AddOptions = FullOptions [Partner] type AddT m = AddT' [Partner] m data Partner = Partner { pUser :: User , partnerAccount :: AccountName -- ^ partner's receivable/payable account in the user's ledger , userAccount :: AccountName -- ^ user's receivable/payable account in the partner's ledger , partnerLedger :: FilePath -- ^ partner's ledger } deriving (Show, Eq) -- | Extract partner information from the env and throw errors if there are any -- readPartner :: (MonadReader AddOptions m, MonadError Msg m) -- => (Partner -> a) -> m (Maybe a) -- readPartner f = reader $ fmap f . oEnv -- -- | Extract partner user partners :: (MonadReader AddOptions m, MonadError Msg m) => m [Partner] partners = reader oEnv -- * Entry point add :: AddT' [Username] IO () add = do user <- user partners <- mapM (toPartner <=< lookupUser) =<< reader oEnv options <- ask let f (user, files) = do journal <- loadJournal (files ++ [Just . addedByThisUser , addedByOthers]) options{ oUser = user } return (name user , journal ) journals <- fmap M.fromList . mapM f $ (user, [Just . imported]) : (fmap (\x -> (pUser x, []) ) partners) withRWST (\r _ -> (r{oEnv = partners}, journals)) $ do liftIO . putStr =<< hello forever mainLoop -- | Convert given 'Username' to 'Partner'. toPartner :: Monad m => User -> AddT' env m Partner toPartner part = do Partner part <$> receivablePayable True part <*> receivablePayable False part <*> maybeThrow msg ($ name part) return (addedByOthers $ ledgers part) where msg = "ledgers.addedByOthers not configured for '"%F.sh%"'" -- | Welcome message hello :: Monad m => AddT m String hello = do un <- readUser name j <- gets M.elems return $ intercalate "\n\n" [ "Hi "<> fshow un <> "!" ,"Use readline keys to edit, use tab key to complete account names." ,"A code (in parentheses) may be entered following transaction dates." ,"A comment may be entered following descriptions or amounts." , show ( sum $ length . jtxns <$> j) ++ " Transactions found" ] -- | main user interaction loop mainLoop :: AddT IO () mainLoop = do liftIO $ putStr "\n\nStarting new transaction...\n" (iAm, match) <- sugTrans let ask = do iDa <- liftIO $ askDate Nothing iDe <- liftIO $ askDescription Nothing user <- user iAc <- myAskAccount user Nothing (Just "learn") (Left "Enter source account" ) return (nulltransaction{tdate=fst iDa, tcode=snd iDa ,tdescription=iDe} ,iAc,iAm) useMatch t = return ( nulltransaction{tdate=tdate t, tdescription=tdescription t} ,paccount p2, AA "" Nothing $ negate $ pamount p2) where _:(p2:_) = tpostings t -- ,paccount p3, ("",negate $ pamount p3)) -- where p3 = fromMaybe (pos!!2) $ asum $ -- (\x -> return x <$> extractSource "HBCI" (pcomment x)) <$> pos -- pos = tpostings t -- PROBLEM1: it's not HBCI, instead sugTrans and clearSecondPosting -- emphazises on the "second" posting (transa,iAc,iAm2) <- maybe ask useMatch match suggs <- suggestedPostings iAc $ Just iAm2 result <- edit myEd transa suggs moveToNextEmpty saveAndClear match (isJust result) =<< finishTransaction True result -- | Saves transaction into the designated ledgers files of each user, -- and clears the transaction tht was matched (conditional on a 'Bool' -- argument) saveAndClear :: Maybe Transaction -- ^ matching transaction for clearing -> Bool -- ^ clear the matching transactions -> (Maybe Transaction, [(Partner, Transaction)]) -- ^ transactioons to be saved: ((user's,other's), -> AddT IO () saveAndClear match clearIt (userT, partnerTS) = do user <- user forM_ userT $ \res -> do -- clear the first posting, of the new transaction, if there was a -- match -- ReferenceA let newt = (if isJust match then clearNthPosting 0 else id) res -- add it to the user's journal (+ file) file <- readLedger addedByThisUser myJournalAddTransaction file user [newt] forM_ partnerTS $ \(partner, tx) -> myJournalAddTransaction (partnerLedger partner) (pUser partner) [tx] -- clear the matching transactions second posting in the file flip traverse_ (guard clearIt *> match) $ \trans -> do oldJ <- getJournal user newJ <- saveChanges (Just oldJ) . changeTransaction . (:[]) $ clearSecondPosting trans modifyJournal user $ const newJ -- TODO use alterF from containers-0.5.9.1 modifyJournal :: MonadState UserJournals m => User -> (Journal -> Journal) -> m () modifyJournal user mod = modify $ M.adjust mod $ name user getJournal :: MonadState UserJournals m => User -> m Journal getJournal user = gets (M.! (name user)) clearSecondPosting :: Transaction -> (Transaction, Transaction) clearSecondPosting t = (t, clearNthPosting 1 t) -- | Split 'EditablePosting's in User's Postings and (Partner, -- Postings, Open Balance) split :: [EditablePosting] -> ([Posting], [(Partner, E.NonEmpty Posting, MixedAmount)]) split = second (fmap h . E.groupBy (on (==) fst)) . partitionEithers . mapMaybe f where f :: EditablePosting -> Maybe (Either Posting (Partner, Posting)) f x = either (const Left) ((Right .) . (,)) (present $ epUser x) <$> epPosting x h :: E.NonEmpty (Partner, Posting) -> (Partner, E.NonEmpty Posting, MixedAmount) h x = (fst $ E.head x, snd <$> x, sum $ pamount . snd <$> x) -- | generate the main and possibly the other users' transactions finishTransaction :: (MonadIO m, MonadReader AddOptions m) => Bool -- ^ require balanced transactions -> Maybe (Transaction, [EditablePosting]) -- ^ the transaction and postings to be combined -> m (Maybe Transaction, [(Partner, Transaction)]) -- ^ (user's, partners') transactions finishTransaction _ Nothing = return (Nothing, []) finishTransaction check (Just (tr,postings)) = do time <- liftIO getCurrentTime us <- user let (userP, partnerPS) = split postings userT = if null x then Nothing else Just $ toTP x where x = userP ++ concatMap userTransfer partnerPS userTransfer (partner, _, sum) = nullP (partnerAccount partner) sum partnerT (partner, ps, sum) = (,) partner $ toTP $ -- this posting allows the other posting to be added to the -- suggested postings maybeToList (phantom <$> userT) ++ nullP (userAccount partner) (negate sum) ++ E.toList ps phantom t = (head $ tpostings t) { pamount = nullmixedamt } toTP ps = (if check then either err id . balanceTransactionIfRequired else id) tr {tpostings = increasePrec <$> ps ,tcomment = comment} nullP acc am = if isReallyZeroMixedAmount am then [] else [nullposting{paccount = acc ,pamount = am}] comment = sformat ("Entered on "%F.sh%" by 'buchhaltung' user "%F.sh) (iso8601 time) $ name us err = (error.("shit, it should be balanced, check source code\n\n"++)) increasePrec p = p{pamount = setMixedAmountPrecision maxprecisionwithpoint $ pamount p} return $ (userT, partnerT <$> partnerPS) iso8601 :: UTCTime -> String iso8601 = formatTime defaultTimeLocale "%FT%TZ" -- | add transaction to ledger file and return new ledger myJournalAddTransaction :: FilePath -> User -> [Transaction] -> AddT IO () myJournalAddTransaction relative user trans = do file <- absolute relative liftIO $ ensureJournalFileExists file -- creates empty journal liftIO $ L.appendFile file $ "\n" <> intercalateL "\n\n" trans' <> "\n" liftIO . L.putStr . sformat ("\nNew transaction created for '" %F.sh% "'\n") . name $ user modifyJournal user $ \j -> j{jtxns=jtxns j ++ trans } where trans' = L.dropWhileEnd (=='\n') . fshow <$> trans :: [T.Text] clearNthPosting :: Int -> Transaction -> Transaction clearNthPosting n t = t{tpostings=p'} where p' = modifyNth (\x -> x{pstatus=Cleared}) n $ tpostings t -- * Transaction suggestions data Asserted a = AA { aComment :: Comment , aAssertion :: Maybe Amount , aAmount :: a } deriving (Functor, Show) instance Default AssertedAmount where def = AA "" Nothing $ mixed' nullamt type AssertedAmount = Asserted MixedAmount fromPosting :: Posting -> Asserted MixedAmount fromPosting = AA <$> pcomment <*> pbalanceassertion <*> pamount showAssertedAmount :: Asserted MixedAmount -> T.Text showAssertedAmount a = showMixedAmount2 (aAmount a) <> maybe "" ((" = " <>) . showAmount2) (aAssertion a) -- | Ask an amount, and return transactions matching the entered -- amount sugTrans :: AddT IO (AssertedAmount, Maybe Transaction) sugTrans = sugTrans' . fmap negate =<< askAmount (Just def) "Enter amount (zero for any transaction)" Nothing where sugTrans' answ@AA{ aAmount = iAm, aAssertion = Nothing} = do accs <- S.fromList . HM.elems <$> askAccountMap user <- readUser id let f user Transaction{tpostings=p1:(p2:_)} = -- the first posting's account contains as prefix one of the accounts -- automatically handled by csv2ledger (any (`T.isPrefixOf` paccount p1) accs) -- the first amount of the first posting matched the entered -- amount in absolute values && (on (==) (abs.aquantity.head.amounts) iAm ( pamount p1 ) -- or the entered amount is zero || mixed' nullamt == iAm -- or the amount occurs in the comment of the second || (comma.fshow.abs.aquantity.head.amounts $ iAm) `L.isInfixOf` pcomment p2 ) -- the second posting is not cleared && not (pstatus p2 == Cleared) -- doch nicht (siehe notiz vom [2013-06-02 Sun]): -- no transaction exists offsetting the second -- posting (e.g. for transactions entered, before they were -- paid) -- && fromMaybe True ( flip Set.notMember s <$> -- toMyP t p2{pamount=negate $ pamount p2}) -- ignore certain accounts && (not $ isIgnored (ignoredAccountsOnAdd user) $ paccount p2) f _ _ = False -- s :: S.Set MyPosting -- s = error "doch benutzt?" -- Set.fromList $ toMyPs =<< jtxns j comma = T.replace "." "," selectMatch :: [Transaction] -> AddT IO (AssertedAmount, Maybe Transaction) selectMatch m = g =<< (liftIO $ choose $ show <$> m') where m' = take 20 $ sortBy (flip $ comparing tdate) m g Manual = return (answ, Nothing) g (Choose i) = return $ (answ, Just $ atNote "selectMatch" m' i) g Reenter = sugTrans selectMatch =<< filter (f user) . jtxns <$> getJournal user sugTrans' a = return (a, Nothing) -- data MyPosting = MyP {mypDay::Day, mypAcc::AccountName,mypAmt::Amount} -- deriving (Show) -- toMyPs t = catMaybes [ toMyP t p | p <- tpostings t ] -- toMyP t p@Posting{pstatus=Uncleared} = -- MyP (tdate t) (paccount p) <$> listToMaybe (amounts $ pamount p) -- --take only first amount -- toMyP _ _ = Nothing -- compareMyPs = comparing (acommodity.mypAmt) && (aquantity.mypAmt) && mypDay && mypAcc -- where (&&) a b = a `Mo.mappend` comparing b -- instance Ord MyPosting where -- compare = compareMyPs -- instance Eq MyPosting where -- (==) = (EQ==).:compareMyPs -- (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -- (.:) = (.) . (.) data Choice = Reenter | Manual | Choose Int -- | user input: choose one from a list of choices choose :: [String] -- ^ choices -> IO Choice choose [] = return Manual choose m = do putStr $ unlines $ reverse $ zipWith pr [1..] m putStr $ unlines [if null m then "" else printf "{number}: use one of the above %d transactions" len ,"'m': enter transaction manually" ,"'r': enter new amount to find existing transations"] either ((>> choose m) . print) return =<< parse (menup len)"menu parser" <$> getLine where pr n t = show n ++ ")\n" ++ t len = length m menup :: Int -> Parser Choice menup limit = stripP $ try (try (char 'r' >> return Reenter) <|> (char 'm' >> return Manual)) <|> do int <-pred . read <$> many1 digit if int < limit then return $ Choose int else fail "number too high" stripP p = do r <- spaces >> p spaces >> eof >> return r -- * Main editing loop -- | combines everything into an 'EditorConf' myEd :: EditorConf (AddT IO) EditablePosting Transaction myEd = EC { getchar = Just myGetchar , ZE.display = dis , ecPrompt = const mainPrompt , actions = [ ('c', ModifyAll clearTrans <> Done quiet ?? "Clear transaction") , ('n', ModifyAllM (addNewPosting False) ?? "Add new posting") , ('N', ModifyAllM (addNewPosting True) ?? "Add new posting for next user") , ('r', ModifyAll (assignOpenBalance 1.0) ?? "Assign open balance to account") , ('h', ModifyAll (assignOpenBalance 2.0) ?? "Assign half of open balance to account") , ('x', Modify removeAmount ?? "Remove current amount") , ('t', ModifyStateM editDescription ?? "Edit title") , ('d', ModifyStateM editDate ?? "Edit date") -- http://www.ledger-cli.org/3.0/doc/ledger3.html#Effective-Dates -- , ('D', ModifyStateM (editDate j) ?? "Edit effective date") , ('e', ModifyAllM editCurAmount ?? "Edit current amount") , ('+', ModifyAllM (modifyCurAmount (\o n -> fmap (on (+) replaceMissing $ aAmount n) o) False) ?? "Add to amount") , ('j', Fwd ?? "Move forward one item.") , ('k', Back ?? "Move backward one item.") , ('Q', Cancel ?? "discard entry and Quit") , ('m', Modify setMissing ?? "set amount to 'missing'") , ('s', Done checkDone ?? "Save entry") , ('c', Done checkDone ?? "Save entry") , ('u', Modify nextNotFirst ?? "Next user") , ('v', ModifyAll (assignOpenBalance (119/19)) ?? "Fill with VAT") , ('p', ModifyAllM ((<$> liftIO askPercent) . flip assignOpenBalance) ?? "Ask for percentage") ] ++ digitActions } where digitActions = [ (intToDigit n, ModifyAll (jumpTo n) ?? ("Edit account"++[intToDigit n])) | n <- [0..9] ] dis LS{userSt=tr,ctx=z} = do -- j <- get return $ L.replicate 60 '~' <> "\n\n" <> fromString (showTransaction tr) -- <> fshow (jparsedefaultcommodity j, jcommodities j, jinferredcommodities j) <> showEditablePosting z mainPrompt :: (L.ListLike m item, IsString m) => m mainPrompt = "\n" <> intercalateL "\n" ( intercalateL " " <$> f) <> "\n" where f = [["[r]est ","[j]next","[u]ser ","[+]add","[t]itle","[?]Help ","[s]ave ","[p]%"] ,["[h]alf ","[k]prev","[n/N]ew","[e]dit","[d]ate ","[x]remove","[Q]discard","[v]AT"] ,[" "," "," ","[m]iss"," "," ","[c]lear "," "]] quiet :: Monad m => a -> m (Maybe a) quiet = return . Just -- | clear all postings clearTrans :: Zipper EditablePosting -> Zipper EditablePosting clearTrans = differentiate . fmap f . integrate' where f x = x{epPosting=Nothing} -- | change user of current posting, but not for the first posting -- ReferenceA nextNotFirst :: EditablePosting -> EditablePosting nextNotFirst s | epNumber s > 0 = next s | otherwise = s balanceTransactionIfRequired :: Transaction -> Either String Transaction balanceTransactionIfRequired tx = do br <- mapM (balanceRequirement . ($ tx)) [realPostings, balancedVirtualPostings] if not $ any required br then return tx else do when (not $ all possible br) $ throwError $ "Not implemented: this transaction has some postings that " ++ "need to be balanced while others cannot be balanced." ++ show br balanceTransaction Nothing tx data Balancing = B { possible :: Bool , required :: Bool } deriving (Show) -- | check, if the transaction should be passed through -- `balanceTransaction` to infer missing amounts balanceRequirement :: MonadError String m => [Posting] -> m Balancing balanceRequirement [] = return $ B True False balanceRequirement ps = if assignments > 0 then if length noAmount - assignments <= 1 then return $ B False False else throwError $ "There cannot be more than one " ++ "posting with neither amount nor assertion" else return $ B True True where noAmount = filter hasAmount ps assignments = length $ filter (isJust . pbalanceassertion) noAmount -- | Try to balance the transactions and present the final -- transactions checkDone :: LState EditablePosting Transaction -> AddT IO (Maybe (LState EditablePosting Transaction)) checkDone st@LS{userSt = trans, ctx = postings} = do user <- user (userT, partnerT) <- finishTransaction False $ Just (trans, integrate postings) let txs :: [(User, Either String Transaction)] txs = second balanceTransactionIfRequired <$> maybeToList ((,) user <$> userT) ++ fmap (first pUser) partnerT res <- liftIO $ mapM g txs return$ if and res then Just st else Nothing where g (u,tx) = either (showR "ERROR" False u) (showR "Balanced Transaction" True u . show) tx showR title ret user msg = do L.putStrLn $ sformat ("####### "%F.sh%": "% (F.center 20 ' '%.F.s) %" #######\n\n"%F.s%"\n") (name user) title msg return ret -- * Asking (with completion) askDescription :: Maybe T.Text -- ^ default -> IO T.Text askDescription = editLoop Right d Nothing Nothing (Left d) where d = "Title" :: IsString a => a -- | uses 'dateandcodep' askDate :: Maybe Day -- ^ default -> IO (Day, T.Text) askDate def = do today <- getCurrentDay let defday = fromMaybe today def -- defday = either (error . ("cannot parse default date:\n"++) . show) -- (fixSmartDate today) $ (parse smartdate "" . lowercase) $ showDate today extract :: T.Text -> Either String (Day, T.Text) extract input = ("Date parsing error "++).show +++ first (fixSmartDate today) $ MP.runParser dateandcodep "" input editLoop extract "Date" (Just ((defday,""), fshow defday)) complList (Left "Date") $ fshow <$> def where complList = Just ["january" , "february" , "march" , "april" , "may" , "june" , "july" , "august" , "september" , "october" , "november" , "december" , "today" , "yesterday" , "tomorrow" , "last" , "this" ,"next"] -- | HLedger's 'smartdate' and code dateandcodep :: MP.Parsec Void T.Text (SmartDate, T.Text) dateandcodep = do d <- smartdate c <- optional codep many spacenonewline MP.eof return (d, maybe "" T.pack c) myAskAccount :: User -> Maybe AccountName -> Maybe String -> Either T.Text T.Text -> AddT IO AccountName myAskAccount user a1 a2 a3= do j <- getJournal user let completionList = nub $ sort [ paccount p | t <- jtxns j, p <- tpostings t] askAccount completionList a1 a2 a3 askAmount :: Maybe AssertedAmount -- ^ default value, if "" is entered -> T.Text -- ^ prompt -> Maybe T.Text -- ^ initial -> AddT IO AssertedAmount askAmount def pr init = do j <- getJournal =<< user liftIO $ editLoop (extract j) "Amount" ((id &&& showAssertedAmount) <$> def) Nothing (Left pr) init where extract :: Journal -> T.Text -> Either String AssertedAmount extract j input = left show $ (\a -> a { aComment = cmt }) <$> parseAmount j am where (am, cmt) = textstrip *** (textstrip . L.dropWhile (==';')) <<< L.break (==';') $ input :: (T.Text, T.Text) -- -- | Parse and update an amount to equal its 'show' value -- -- -- -- this is required to ensure, that the saved transaction equals the -- -- edited and balanced transaction. -- toShow :: Journal -> MixedAmount -> MixedAmount -- toShow j (Mixed ams) = Mixed $ fmap g ams -- where g = either (error.show) id . parseAmount j . fshow parseAmount :: Journal -> T.Text -> Either (MP.ParseError Char Void) AssertedAmount parseAmount j = parseWithState' j $ ((flip $ AA "") <$> (fmap (Mixed . pure) $ amountp MP.<|> return missingamt) <*> partialbalanceassertionp ) <* MP.eof -- | (unused) overwrite upstream behavior to use defined or incurred -- commodities _amountp2 = MP.try leftsymbolamountp MP.<|> MP.try rightsymbolamountp MP.<|> nosymbolamountp2 nosymbolamountp2 :: Monad m => JournalParser m Amount nosymbolamountp2 = do (q,prec,mdec,mgrps) <- lift numberp p <- priceamountp -- apply the most recently seen default commodity and style to this commodityless amount defcs <- getDefaultCommodityAndStyle2 <$> get let (c,s) = case defcs of Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec}) Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}) return $ Amount c q p s False MP. "no-symbol amount" getDefaultCommodityAndStyle2 :: Journal -> Maybe (CommoditySymbol,AmountStyle) getDefaultCommodityAndStyle2 Journal{jparsedefaultcommodity=def ,jcommodities=comms ,jinferredcommodities=inferred} = let mm = listToMaybe . M.toList in asum [def ,traverse cformat =<< mm comms ,mm inferred ] askPercent :: IO Decimal askPercent = editLoop extr "percent" (Just ((,).prep <*> fshow $ def)) Nothing (Left "Percentage") Nothing where extr :: T.Text -> Either String Decimal extr s = show +++ prep $ readEither $ T.unpack s def = -1.5 :: Decimal prep = (100*).recip -- * Posting and Suggestions -- | Type holding suggested or temporary postings data EditablePosting = EditablePosting { epPosting :: Maybe Posting , epFreq :: Maybe Int , epAccount :: AccountName , epNumber :: Int , epUser :: Zipper (Either User Partner) -- ^ zipper of possible user } type EditablePostings = Zipper EditablePosting -- | construct an 'EditablePosting' editablePosting account amt freq n users = addPosting account amt EditablePosting { epAccount = account , epFreq=freq , epNumber=n , epPosting = Nothing , epUser = users } -- for each user and partner a zipper that has them at the front and -- an infinite repetition of the other users in the past. userZippers = do partners <- partners user <- user return $ take (succ $ length partners) $ iterate fwd $ differentiate $ E.cycle $ Left user E.:| (Right <$> partners) -- | generate and add new 'Posting' to 'EditablePosting' addPosting :: AccountName -> Maybe AssertedAmount -> EditablePosting -> EditablePosting addPosting _ Nothing s = s addPosting account (Just (AA cmt ass iam)) s = s{epPosting=Just nullposting { paccount=account , pcomment = cmt , pbalanceassertion = ass , pamount = iam}} setMissing :: EditablePosting -> EditablePosting setMissing ep = addPosting (epAccount ep) (Just $ missingmixedamt <$ maybe def fromPosting (epPosting ep)) ep removeAmount :: EditablePosting -> EditablePosting removeAmount ep = ep{epPosting=Nothing} -- | jump to a certain element in a zipper jumpTo :: Int -> Zipper a -> Zipper a jumpTo n z' = atNote "jumpTo" (iterate fwd . differentiate . integrate' $ z') n editDate :: LState a Transaction -> AddT IO (LState a Transaction) editDate s@LS{userSt=t@Transaction{tdate=d}} = liftIO $ do iDa <- askDate (Just d) return s{userSt=t{tdate=fst iDa,tcode=snd iDa}} editDescription :: LState a Transaction -> AddT IO (LState a Transaction) editDescription s@LS{userSt=t@Transaction{tdescription=d}} = liftIO $ do iDe <- askDescription (Just d) return s{userSt=t{tdescription=iDe}} -- | edit the amount of the selected posting editCurAmount :: EditablePostings -> AddT IO EditablePostings editCurAmount = modifyCurAmount (const id) True -- | modfiy current amount by asking for a new amount, that is -- combined with the old to get a new amount (e.g. with (+)) modifyCurAmount ::(AssertedAmount -> AssertedAmount -> AssertedAmount) -- ^ oldAmout -> enteredAmount -> newAmount -> Bool -- ^ Show old amound -> EditablePostings -> AddT IO EditablePostings modifyCurAmount new showO z@LZ{past=(s@EditablePosting{epAccount=ac} E.:| ps)} = do iAm <- askAmount olda ("Amount for " <> ac) solda return $ moveToNextEmpty z { past = addPosting ac (Just $ maybe iAm (flip new iAm) olda) s E.:| ps } where olda = fromPosting <$> epPosting s solda = guard showO *> fmap showAssertedAmount olda replaceMissing :: MixedAmount -> MixedAmount replaceMissing amt | normaliseMixedAmount amt == missingmixedamt = nullmixedamt | True = amt -- | Hardcoded default number of suggested accounts defNumSuggestedAccounts :: Int defNumSuggestedAccounts = 20 suggestedPostingsSingleUser :: Monad m => T.Text -> Zipper (Either User Partner) -> AddT m [EditablePosting] suggestedPostingsSingleUser account userZipper = do j <- getJournal user return $ filterOtherUsersAccounts $ sortBy (flip $ comparing epFreq) $ fmap toEp $ group $ sort $ concatMap tail $ filter filt $ ((paccount<$>) . tpostings) <$> jtxns j where user = getUser $ present userZipper filt x = account == head x && not ( null x ) toEp accounts = editablePosting (head accounts) Nothing (Just $ length accounts) 0 userZipper filterOtherUsersAccounts = maybe id (\x -> filter $ not . L.isPrefixOf (x <> ":") . epAccount) $ accountPrefixOthers user -- | retrieve a number of suggested contra postings for a given -- account, sort frequency of that contra account for the given -- account. -- -- TODO incorporate old behavior: -- duplicate each posting for both users, but only if the -- other user's account is present in the suggestions. suggestedPostings :: MonadIO m => AccountName -> Maybe AssertedAmount -> AddT m (E.NonEmpty EditablePosting) suggestedPostings account am = do userZippers <- userZippers let firstP = editablePosting account am Nothing 0 $ head userZippers -- ReferenceA num <- fromMaybe defNumSuggestedAccounts <$> readUser numSuggestedAccounts (E.:|) firstP . take (pred num) . zipWith (\n p -> p{epNumber=n}) [1..] . concat <$> mapM (suggestedPostingsSingleUser account) userZippers -- | change posting's user to the next user next :: EditablePosting -> EditablePosting next s = s{epUser = fwd $ epUser s} roundP :: EditablePosting -> EditablePosting roundP p = p{epPosting = r1 <$> epPosting p} where r1 p = p{pamount = normalizeMixedAmountWith g $ pamount p} g a = roundTo (fromIntegral $ asprecision $ astyle a) $ aquantity a -- | assign the 'Transaction''s open balance to an empty 'EditablePosting' assignOpenBalance :: Decimal -> EditablePostings -> EditablePostings assignOpenBalance c old@LZ{past=(pr@EditablePosting{epAccount=sac} E.:| ps)} = moveToNextEmpty $ old{past= roundP (newp $ epPosting pr) E.:| ps} where balance = divideMixedAmount (totalBalance all) c all = integrate old newp Nothing = addPosting sac (Just $ AA "" Nothing balance) pr newp (Just op) = pr{epPosting = Just op{pamount= balance + pamount op }} showEditablePosting :: EditablePostings -> T.Text showEditablePosting LZ{past= pr E.:| ps ,future=fut} = renderTable (replicate 4 AlignCenter,replicate 4 AlignLeft, [ "Account", "Amount", "Assertion", "Frequency"]) [ let mark = if marked then "->" else " " :: String in [ sformat (F.d % "," %F.sh% " " %F.s% " " %F.st) (epNumber x) (name $ getUser $ present $ epUser x) mark $ epAccount x ,maybe "" (showMissing . pamount) $ epPosting x ,maybe "" (("= " <>) . showAmount2) $ pbalanceassertion =<< epPosting x ,maybe "" fshow $ epFreq x ] | (marked,x) <- postings ] $ Just ["Open Balance",balance,""] where balance = showMixedAmount2 $ totalBalance $ snd <$> postings postings = reverse ((,) True pr : mark ps) ++ mark fut mark = ((,) False <$>) showMissing amt | normaliseMixedAmount amt == missingmixedamt = "missing" | True = showMixedAmount2 amt getUser :: Either User Partner -> User getUser = either id pUser totalBalance :: [EditablePosting] -> MixedAmount totalBalance = negate . sum . fmap pamount . mapMaybe epPosting showAmount2 :: Amount -> T.Text showAmount2 = showMixedAmount2 . mixed' showMixedAmount2 :: MixedAmount -> T.Text showMixedAmount2 amt = T.pack $ showMixedAmountWithPrecision maxprecisionwithpoint amt -- | ask for new account (display old as default) and use existing -- posting, if same account without a posting/amount already exists or -- append. addNewPosting :: Bool -- ^ for next partner -> EditablePostings -> AddT IO EditablePostings addNewPosting forNext old' = do let postings = integrate old' nextP = (if forNext then fwd else id) $ epUser $ present old' account <- myAskAccount (getUser $ present nextP) (Just $ epAccount $ present old') Nothing $ Left "Account" new <- editablePosting account Nothing Nothing (length postings) . head <$> userZippers let loop (ep:eps) done = if isNothing (epPosting ep) && epAccount ep == account && on (==) present nextP (epUser ep) then LZ (addPosting account Nothing ep E.:| done) eps else loop eps (ep:done) loop [] done = LZ (new E.:| done) [] return $ modifyPresent (\x -> x{epUser = nextP}) $ loop postings [] -- | move the focus to the next empty posting moveToNextEmpty :: EditablePostings -> EditablePostings moveToNextEmpty z = fromMaybe z $ find f zs where zs = take (length postings) $ iterate wrapFwd z postings = integrate' z f = isNothing . epPosting . E.head . past wrapFwd x = if null $ future x then differentiate postings else fwd x -- * Pretty Table Printer -- a type for fill functions data Align = AlignLeft | AlignRight | AlignCenter -- functions that fill a string (s) to a given width (n) by adding pad -- character (c) to align left, right, or center fillLeft c n s = s <> L.replicate (n - L.length s) c fillRight c n s = L.replicate (n - L.length s) c <> s fillCenter c n s = L.replicate l c <> s <> L.replicate r c where x = n - L.length s l = x `div` 2 r = x - l -- converts a list of items into a table according to a list -- of column descriptors renderTable :: ([Align],[Align],[T.Text]) -> [[T.Text]] -> Maybe [T.Text] -> T.Text renderTable (headerAlign,rowAlign,header) rows footer = let widths = [maximum $ map L.length col | col <- transpose $ (header : rows) ++ maybeToList footer] :: [Int] separator = intercalateL "-+-" [L.replicate width '-' | width <- widths] fillCols fill cols = intercalateL " | " $ zipWith3 (($).) fill widths cols in L.unlines ( fillCols headerFill header : separator : map (fillCols rowFill) rows ++ maybe [] (\x -> [separator, fillCols rowFill x]) footer) where toFiller AlignLeft = fillLeft ' ' toFiller AlignRight = fillRight ' ' toFiller AlignCenter = fillCenter ' ' headerFill = toFiller <$> headerAlign rowFill = toFiller <$> rowAlign