module Penny.Lincoln.Transaction (
Posting,
Transaction,
PostFam (unPostFam),
transaction,
Error ( UnbalancedError, CouldNotInferError),
Inferred(Inferred, NotInferred),
pPayee, pNumber, pFlag, pAccount, pTags,
pEntry, pMemo, pInferred, pMeta, changePostingMeta,
TopLine,
tDateTime, tFlag, tNumber, tPayee, tMemo, tMeta,
unTransaction, postFam, changeTransactionMeta,
addSerialsToList, addSerialsToEithers,
Box ( Box, boxMeta, boxPostFam )
) where
import qualified Penny.Lincoln.Bits as B
import Penny.Lincoln.Family ( children, orphans, adopt )
import qualified Penny.Lincoln.Meta as M
import qualified Penny.Lincoln.Family.Family as F
import qualified Penny.Lincoln.Family.Child as C
import qualified Penny.Lincoln.Family.Siblings as S
import qualified Penny.Lincoln.Transaction.Unverified as U
import qualified Penny.Lincoln.Balance as Bal
import qualified Penny.Lincoln.Serial as Ser
import Control.Monad.Exception.Synchronous (
Exceptional (Exception, Success) , throw )
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Either as E
import qualified Data.Foldable as Fdbl
import Data.Maybe ( catMaybes )
import qualified Data.Traversable as Tr
import qualified Control.Monad.Trans.State.Lazy as St
import Control.Monad.Trans.Class ( lift )
data Inferred = Inferred | NotInferred deriving (Eq, Show)
data Posting =
Posting { pPayee :: (Maybe B.Payee)
, pNumber :: (Maybe B.Number)
, pFlag :: (Maybe B.Flag)
, pAccount :: B.Account
, pTags :: B.Tags
, pEntry :: B.Entry
, pMemo :: B.Memo
, pInferred :: Inferred
, pMeta :: M.PostingMeta }
deriving (Eq, Show)
data TopLine =
TopLine { tDateTime :: B.DateTime
, tFlag :: (Maybe B.Flag)
, tNumber :: (Maybe B.Number)
, tPayee :: (Maybe B.Payee)
, tMemo :: B.Memo
, tMeta :: M.TopLineMeta }
deriving (Eq, Show)
newtype Transaction =
Transaction { unTransaction :: F.Family TopLine Posting }
deriving (Eq, Show)
data Error = UnbalancedError
| CouldNotInferError
deriving (Eq, Show)
newtype PostFam = PostFam { unPostFam :: C.Child TopLine Posting }
deriving Show
postFam :: Transaction -> [PostFam]
postFam (Transaction ps) = map PostFam . Fdbl.toList . children $ ps
transaction ::
F.Family U.TopLine U.Posting
-> Exceptional Error Transaction
transaction f@(F.Family p _ _ _) = do
let os = orphans f
t = totalAll os
p' = toTopLine p
a2 <- inferAll os t
return $ Transaction (adopt p' a2)
totalAll :: S.Siblings U.Posting
-> Bal.Balance
totalAll =
Fdbl.foldr1 Bal.addBalances
. catMaybes
. Fdbl.toList
. fmap (fmap Bal.entryToBalance . U.entry)
infer ::
U.Posting
-> Ex.ExceptionalT Error
(St.State (Maybe B.Entry)) Posting
infer po =
case U.entry po of
Nothing -> do
st <- lift St.get
case st of
Nothing -> Ex.throwT CouldNotInferError
(Just e) -> do
lift $ St.put Nothing
return $ toPosting po e Inferred
(Just e) -> return $ toPosting po e NotInferred
runInfer ::
Maybe B.Entry
-> S.Siblings U.Posting
-> Exceptional Error (S.Siblings Posting)
runInfer me pos = do
let (res, finalSt) = St.runState ext me
ext = Ex.runExceptionalT (Tr.mapM infer pos)
case finalSt of
(Just _) -> throw UnbalancedError
Nothing -> case res of
(Exception e) -> throw e
(Success g) -> return g
inferAll ::
S.Siblings U.Posting
-> Bal.Balance
-> Exceptional Error (S.Siblings Posting)
inferAll pos t = do
en <- case Bal.isBalanced t of
Bal.Balanced -> return Nothing
(Bal.Inferable e) -> return $ Just e
Bal.NotInferable -> throw UnbalancedError
runInfer en pos
toPosting :: U.Posting
-> B.Entry
-> Inferred
-> Posting
toPosting (U.Posting p n f a t _ m mt) e i =
Posting p n f a t e m i mt
toTopLine :: U.TopLine -> TopLine
toTopLine (U.TopLine d f n p m mt) =
TopLine d f n p m mt
changeTransactionMeta ::
(M.TopLineMeta -> M.TopLineMeta)
-> Transaction
-> Transaction
changeTransactionMeta fm (Transaction f) = Transaction f' where
f' = F.Family tl c1 c2 cs
(F.Family p c1 c2 cs) = f
tl = p { tMeta = fm (tMeta tl) }
changePostingMeta ::
(M.PostingMeta -> M.PostingMeta)
-> Transaction
-> Transaction
changePostingMeta f (Transaction fam) =
Transaction . F.mapChildren g $ fam
where
g p = p { pMeta = f (pMeta p) }
addSerials ::
(Ser.Serial -> M.TopLineMeta -> M.TopLineMeta)
-> (Ser.Serial -> M.PostingMeta -> M.PostingMeta)
-> Ser.Serial
-> Transaction
-> St.State (Ser.NextFwd, Ser.NextBack) Transaction
addSerials ft fp s (Transaction fam) = do
let topMapper pm = pm { tMeta = ft s (tMeta pm) }
pstgMapper ser pstg = pstg { pMeta = fp ser (pMeta pstg) }
fam' = F.mapParent topMapper fam
fam'' <- Ser.serialChildrenInFamily pstgMapper fam'
return $ Transaction fam''
addSerialsToList ::
(Ser.Serial -> M.TopLineMeta -> M.TopLineMeta)
-> (Ser.Serial -> M.PostingMeta -> M.PostingMeta)
-> [Transaction]
-> [Transaction]
addSerialsToList ft fp ls =
let nPstgs = length . concatMap Fdbl.toList . map orphans
. map unTransaction $ ls
initState = Ser.initNexts nPstgs
processor = addSerials ft fp
in St.evalState (Ser.serialItemsM processor ls) initState
addSerialsToEithers ::
(Ser.Serial -> M.TopLineMeta -> M.TopLineMeta)
-> (Ser.Serial -> M.PostingMeta -> M.PostingMeta)
-> [Either a Transaction]
-> [Either a Transaction]
addSerialsToEithers ft fp ls =
let txns = E.rights ls
nPstgs = length . concatMap Fdbl.toList . map orphans
. map unTransaction $ txns
initState = Ser.initNexts nPstgs
processA _ a = return a
processTxn = addSerials ft fp
k = Ser.serialEithers processA processTxn ls
in St.evalState k initState
data Box m =
Box { boxMeta :: m
, boxPostFam :: PostFam }
deriving Show
instance Functor Box where
fmap f (Box m pf) = Box (f m) pf