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)
type UserJournals = M.Map Username Journal
type AddT' env m = RWST (FullOptions env) () UserJournals (ErrorT m)
type AddOptions = FullOptions [Partner]
type AddT m = AddT' [Partner] m
data Partner = Partner
{ pUser :: User
, partnerAccount :: AccountName
, userAccount :: AccountName
, partnerLedger :: FilePath
}
deriving (Show, Eq)
partners
:: (MonadReader AddOptions m, MonadError Msg m) => m [Partner]
partners = reader oEnv
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
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%"'"
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"
]
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
(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
saveAndClear :: Maybe Transaction
-> Bool
-> (Maybe Transaction, [(Partner, Transaction)])
-> AddT IO ()
saveAndClear match clearIt (userT, partnerTS) = do
user <- user
forM_ userT $ \res -> do
let newt = (if isJust match then clearNthPosting 0 else id) res
file <- readLedger addedByThisUser
myJournalAddTransaction file user [newt]
forM_ partnerTS $ \(partner, tx) ->
myJournalAddTransaction (partnerLedger partner) (pUser partner) [tx]
flip traverse_ (guard clearIt *> match) $ \trans -> do
oldJ <- getJournal user
newJ <- saveChanges (Just oldJ) .
changeTransaction . (:[]) $ clearSecondPosting trans
modifyJournal user $ const newJ
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] -> ([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)
finishTransaction :: (MonadIO m, MonadReader AddOptions m)
=> Bool
-> Maybe (Transaction, [EditablePosting])
-> m (Maybe Transaction, [(Partner, Transaction)])
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 $
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"
myJournalAddTransaction ::
FilePath -> User -> [Transaction] -> AddT IO ()
myJournalAddTransaction relative user trans = do
file <- absolute relative
liftIO $ ensureJournalFileExists file
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
data Asserted a = AA { aComment :: Comment
, aAssertion :: BalanceAssertion
, 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 . fst) (aAssertion a)
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:_)} =
(any (`T.isPrefixOf` paccount p1) accs)
&& (on (==) (abs.aquantity.head.amounts) iAm ( pamount p1 )
|| mixed' nullamt == iAm
|| (comma.fshow.abs.aquantity.head.amounts $ iAm)
`L.isInfixOf` pcomment p2 )
&& not (pstatus p2 == Cleared)
&& (not $ isIgnored (ignoredAccountsOnAdd user) $ paccount p2)
f _ _ = False
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 Choice = Reenter | Manual | Choose Int
choose :: [String]
-> 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
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")
, ('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
return $ L.replicate 60 '~' <> "\n\n"
<> fromString (showTransaction tr)
<> 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
clearTrans :: Zipper EditablePosting -> Zipper EditablePosting
clearTrans = differentiate . fmap f . integrate'
where f x = x{epPosting=Nothing}
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)
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
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
askDescription :: Maybe T.Text
-> IO T.Text
askDescription = editLoop Right d Nothing Nothing (Left d)
where d = "Title" :: IsString a => a
askDate :: Maybe Day
-> IO (Day, T.Text)
askDate def = do
today <- getCurrentDay
let
defday = fromMaybe today def
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"]
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
-> T.Text
-> Maybe T.Text
-> 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)
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
_amountp2 = MP.try leftsymbolamountp
MP.<|> MP.try rightsymbolamountp
MP.<|> nosymbolamountp2
nosymbolamountp2 :: Monad m => JournalParser m Amount
nosymbolamountp2 = do
(q,prec,mdec,mgrps) <- lift $ numberp Nothing
p <- priceamountp
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
data EditablePosting = EditablePosting { epPosting :: Maybe Posting
, epFreq :: Maybe Int
, epAccount :: AccountName
, epNumber :: Int
, epUser :: Zipper (Either User Partner)
}
type EditablePostings = Zipper EditablePosting
editablePosting account amt freq n users =
addPosting account amt EditablePosting
{ epAccount = account
, epFreq=freq
, epNumber=n
, epPosting = Nothing
, epUser = users }
userZippers = do
partners <- partners
user <- user
return $ take (succ $ length partners) $ iterate fwd $
differentiate $ E.cycle $ Left user E.:| (Right <$> partners)
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}
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}}
editCurAmount :: EditablePostings -> AddT IO EditablePostings
editCurAmount = modifyCurAmount (const id) True
modifyCurAmount ::(AssertedAmount -> AssertedAmount -> AssertedAmount)
-> Bool
-> 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
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
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
num <- fromMaybe defNumSuggestedAccounts <$>
readUser numSuggestedAccounts
(E.:|) firstP . take (pred num) .
zipWith (\n p -> p{epNumber=n}) [1..] . concat <$>
mapM (suggestedPostingsSingleUser account) userZippers
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
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 . fst)
$ 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
addNewPosting :: Bool
-> 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 []
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
data Align = AlignLeft | AlignRight | AlignCenter
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
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