module Penny.Lincoln.Transaction (
Posting,
Transaction,
PostFam,
unPostFam,
transaction,
RTransaction(..),
rTransaction,
Error ( UnbalancedError, CouldNotInferError),
toUnverified,
Inferred(Inferred, NotInferred),
pPayee, pNumber, pFlag, pAccount, pTags,
pEntry, pMemo, pInferred, pPostingLine,
pGlobalPosting, pFilePosting,
TopLine,
tDateTime, tFlag, tNumber, tPayee, tMemo, tTopLineLine,
tTopMemoLine, tFilename, tGlobalTransaction, tFileTransaction,
unTransaction, postFam,
Box ( Box, boxMeta, boxPostFam ),
TopLineChangeData(..),
emptyTopLineChangeData,
PostingChangeData(..),
emptyPostingChangeData,
changeTransaction
) where
import qualified Penny.Lincoln.Bits as B
import Penny.Lincoln.Family ( children, orphans, adopt )
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 Control.Monad.Exception.Synchronous (
Exceptional (Exception, Success) , throw )
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Foldable as Fdbl
import Data.Maybe ( catMaybes, fromMaybe )
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 :: Maybe B.Memo
, pInferred :: Inferred
, pPostingLine :: Maybe B.PostingLine
, pGlobalPosting :: Maybe B.GlobalPosting
, pFilePosting :: Maybe B.FilePosting
}
deriving (Eq, Show)
data TopLine =
TopLine { tDateTime :: B.DateTime
, tFlag :: Maybe B.Flag
, tNumber :: Maybe B.Number
, tPayee :: Maybe B.Payee
, tMemo :: Maybe B.Memo
, tTopLineLine :: Maybe B.TopLineLine
, tTopMemoLine :: Maybe B.TopMemoLine
, tFilename :: Maybe B.Filename
, tGlobalTransaction :: Maybe B.GlobalTransaction
, tFileTransaction :: Maybe B.FileTransaction }
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
toUnverified :: Transaction -> F.Family U.TopLine U.Posting
toUnverified = F.mapParent fp . F.mapChildren fc . unTransaction
where
fp tl = toUTopLine tl
fc p = toUPosting p
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.pEntry)
infer ::
U.Posting
-> Ex.ExceptionalT Error
(St.State (Maybe B.Entry)) Posting
infer po =
case U.pEntry 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
toUPosting :: Posting -> U.Posting
toUPosting p = U.Posting
{ U.pPayee = pPayee p
, U.pNumber = pNumber p
, U.pFlag = pFlag p
, U.pAccount = pAccount p
, U.pTags = pTags p
, U.pEntry = case pInferred p of
Inferred -> Nothing
NotInferred -> Just (pEntry p)
, U.pMemo = pMemo p
, U.pPostingLine = pPostingLine p
, U.pGlobalPosting = pGlobalPosting p
, U.pFilePosting = pFilePosting p
}
toPosting :: U.Posting
-> B.Entry
-> Inferred
-> Posting
toPosting u e i =
Posting
{ pPayee = U.pPayee u
, pNumber = U.pNumber u
, pFlag = U.pFlag u
, pAccount = U.pAccount u
, pTags = U.pTags u
, pEntry = e
, pMemo = U.pMemo u
, pInferred = i
, pPostingLine = U.pPostingLine u
, pGlobalPosting = U.pGlobalPosting u
, pFilePosting = U.pFilePosting u
}
toUTopLine :: TopLine -> U.TopLine
toUTopLine t = U.TopLine
{ U.tDateTime = tDateTime t
, U.tFlag = tFlag t
, U.tNumber = tNumber t
, U.tPayee = tPayee t
, U.tMemo = tMemo t
, U.tTopLineLine = tTopLineLine t
, U.tTopMemoLine = tTopMemoLine t
, U.tFilename = tFilename t
, U.tGlobalTransaction = tGlobalTransaction t
, U.tFileTransaction = tFileTransaction t
}
toTopLine :: U.TopLine -> TopLine
toTopLine t = TopLine
{ tDateTime = U.tDateTime t
, tFlag = U.tFlag t
, tNumber = U.tNumber t
, tPayee = U.tPayee t
, tMemo = U.tMemo t
, tTopLineLine = U.tTopLineLine t
, tTopMemoLine = U.tTopMemoLine t
, tFilename = U.tFilename t
, tGlobalTransaction = U.tGlobalTransaction t
, tFileTransaction = U.tFileTransaction t
}
fromRPosting :: U.RPosting -> B.Entry -> Inferred -> Posting
fromRPosting u e i = Posting
{ pPayee = U.rPayee u
, pNumber = U.rNumber u
, pFlag = U.rFlag u
, pAccount = U.rAccount u
, pTags = U.rTags u
, pEntry = e
, pMemo = U.rMemo u
, pInferred = i
, pPostingLine = U.rPostingLine u
, pGlobalPosting = U.rGlobalPosting u
, pFilePosting = U.rFilePosting u
}
fromIPosting :: U.IPosting -> B.Entry -> Inferred -> Posting
fromIPosting u e i = Posting
{ pPayee = U.iPayee u
, pNumber = U.iNumber u
, pFlag = U.iFlag u
, pAccount = U.iAccount u
, pTags = U.iTags u
, pEntry = e
, pMemo = U.iMemo u
, pInferred = i
, pPostingLine = U.iPostingLine u
, pGlobalPosting = U.iGlobalPosting u
, pFilePosting = U.iFilePosting u
}
data RTransaction = RTransaction
{ rtCommodity :: B.Commodity
, rtSide :: Maybe B.Side
, rtSpaceBetween :: Maybe B.SpaceBetween
, rtDrCr :: B.DrCr
, rtTopLine :: U.TopLine
, rtPosting :: U.RPosting
, rtMorePostings :: [U.RPosting]
, rtIPosting :: U.IPosting
} deriving Show
rTransaction :: RTransaction -> Transaction
rTransaction rt = Transaction (F.Family tl p1 p2 ps)
where
tl = toTopLine (rtTopLine rt)
tot = foldl1 B.add $ (U.rQty . rtPosting $ rt)
: map U.rQty (rtMorePostings rt)
sd = rtSide rt
sb = rtSpaceBetween rt
inf = fromIPosting (rtIPosting rt)
( B.Entry (B.opposite (rtDrCr rt))
(B.Amount tot (rtCommodity rt) sd sb))
Inferred
toPstg p = fromRPosting p
(B.Entry (rtDrCr rt)
(B.Amount (U.rQty p) (rtCommodity rt) sd sb)) NotInferred
p1 = toPstg . rtPosting $ rt
(p2, ps) = case rtMorePostings rt of
[] -> (inf, [])
x:xs -> (toPstg x, (map toPstg xs) ++ [inf])
data Box m =
Box { boxMeta :: m
, boxPostFam :: PostFam }
deriving Show
instance Functor Box where
fmap f (Box m pf) = Box (f m) pf
data TopLineChangeData = TopLineChangeData
{ tcDateTime :: Maybe B.DateTime
, tcFlag :: Maybe (Maybe B.Flag)
, tcNumber :: Maybe (Maybe B.Number)
, tcPayee :: Maybe (Maybe B.Payee)
, tcMemo :: Maybe (Maybe B.Memo)
, tcTopLineLine :: Maybe (Maybe B.TopLineLine)
, tcTopMemoLine :: Maybe (Maybe B.TopMemoLine)
, tcFilename :: Maybe (Maybe B.Filename)
, tcGlobalTransaction :: Maybe (Maybe B.GlobalTransaction)
, tcFileTransaction :: Maybe (Maybe B.FileTransaction)
} deriving Show
emptyTopLineChangeData :: TopLineChangeData
emptyTopLineChangeData = TopLineChangeData
{ tcDateTime = Nothing
, tcFlag = Nothing
, tcNumber = Nothing
, tcPayee = Nothing
, tcMemo = Nothing
, tcTopLineLine = Nothing
, tcTopMemoLine = Nothing
, tcFilename = Nothing
, tcGlobalTransaction = Nothing
, tcFileTransaction = Nothing
}
applyTopLineChange :: TopLineChangeData -> TopLine -> TopLine
applyTopLineChange c t = TopLine
{ tDateTime = fromMaybe (tDateTime t) (tcDateTime c)
, tFlag = fromMaybe (tFlag t) (tcFlag c)
, tNumber = fromMaybe (tNumber t) (tcNumber c)
, tPayee = fromMaybe (tPayee t) (tcPayee c)
, tMemo = fromMaybe (tMemo t) (tcMemo c)
, tTopLineLine = fromMaybe (tTopLineLine t) (tcTopLineLine c)
, tTopMemoLine = fromMaybe (tTopMemoLine t) (tcTopMemoLine c)
, tFilename = fromMaybe (tFilename t) (tcFilename c)
, tGlobalTransaction = fromMaybe (tGlobalTransaction t)
(tcGlobalTransaction c)
, tFileTransaction = fromMaybe (tFileTransaction t)
(tcFileTransaction c)
}
data PostingChangeData = PostingChangeData
{ pcPayee :: Maybe (Maybe B.Payee)
, pcNumber :: Maybe (Maybe B.Number)
, pcFlag :: Maybe (Maybe B.Flag)
, pcAccount :: Maybe B.Account
, pcTags :: Maybe B.Tags
, pcMemo :: Maybe (Maybe B.Memo)
, pcSide :: Maybe (Maybe B.Side)
, pcSpaceBetween :: Maybe (Maybe B.SpaceBetween)
, pcPostingLine :: Maybe (Maybe B.PostingLine)
, pcGlobalPosting :: Maybe (Maybe B.GlobalPosting)
, pcFilePosting :: Maybe (Maybe B.FilePosting)
} deriving Show
emptyPostingChangeData :: PostingChangeData
emptyPostingChangeData = PostingChangeData
{ pcPayee = Nothing
, pcNumber = Nothing
, pcFlag = Nothing
, pcAccount = Nothing
, pcTags = Nothing
, pcMemo = Nothing
, pcSide = Nothing
, pcSpaceBetween = Nothing
, pcPostingLine = Nothing
, pcGlobalPosting = Nothing
, pcFilePosting = Nothing
}
applyPostingChange :: PostingChangeData -> Posting -> Posting
applyPostingChange c p = Posting
{ pPayee = fromMaybe (pPayee p) (pcPayee c)
, pNumber = fromMaybe (pNumber p) (pcNumber c)
, pFlag = fromMaybe (pFlag p) (pcFlag c)
, pAccount = fromMaybe (pAccount p) (pcAccount c)
, pTags = fromMaybe (pTags p) (pcTags c)
, pEntry = en
, pMemo = fromMaybe (pMemo p) (pcMemo c)
, pInferred = pInferred p
, pPostingLine = fromMaybe (pPostingLine p) (pcPostingLine c)
, pGlobalPosting = fromMaybe (pGlobalPosting p) (pcGlobalPosting c)
, pFilePosting = fromMaybe (pFilePosting p) (pcFilePosting c)
}
where
enOld = pEntry p
amOld = B.amount enOld
en = B.Entry (B.drCr enOld) am
am = B.Amount (B.qty amOld) (B.commodity amOld) sd sb
sd = fromMaybe (B.side amOld) (pcSide c)
sb = fromMaybe (B.spaceBetween amOld) (pcSpaceBetween c)
changeTransaction
:: F.Family TopLineChangeData PostingChangeData
-> Transaction
-> Transaction
changeTransaction c (Transaction t) =
let F.Family ctl cp1 cp2 cps = c
F.Family tl p1 p2 ps = t
tl' = applyTopLineChange ctl tl
p1' = applyPostingChange cp1 p1
p2' = applyPostingChange cp2 p2
ps' = zipWith applyPostingChange
(cps ++ repeat emptyPostingChangeData) ps
in Transaction (F.Family tl' p1' p2' ps')