module HAX.Accounting where
import HAX.Bookkeeping.Internal
import HAX.Bookkeeping
import Control.Monad.RWS.Strict
import HAX.Common
import qualified Data.Map as M
data World = World { wLife :: (ADate,ADate)
, wEntites :: [Entity]
}
data Entity = forall body . Body body => Entity {
entName :: EntityName
, entAssets :: [AssetName]
, entMonthlyAction :: AccountingRW body ()
, entBody :: body
}
class Body body where
nominalAccounts :: body -> [String]
bodyMonthly :: AccountingRW body ()
-> AccountingRW body ()
simple :: ADate -> body -> AccountingRW body a -> IO a
simple date body action = do
bals <- newArray ((date,1),(date,1)) 0
txns <- newArray (date,date) []
let ledger = UNSAFE_Ledger bals txns
fst <$> evalRWST action (Env ledger M.empty date body Nothing) ()
generate :: World -> IO FullLedger
generate (World times entities) = do
let entityNames = entName <$> entities
eAccounts (Entity name assets _ body) =
assets ++ nominalAccounts body
++ (filter (name /=) entityNames)
allAccounts = M.fromList $ zip accountList [1..]
accountList = [ FAN (entName e) a | e <- entities, a <- eAccounts e ]
nAccs = M.size allAccounts
when (length accountList /= M.size allAccounts) $
error $ "AccountNames are not unique: "++
(unlines$show<$>accountList)
printf "Created a ledger with %v accounts\n" nAccs
bals <- newArray ((fst times,1),(snd times,nAccs)) 0
txns <- newArray times []
let ledger = UNSAFE_Ledger bals txns
monthAction = do
uNSAFE_carryOver
checkTransactionalAcountSymmetry entityNames
sequence_ [withRWT (\e -> e{eBody=body, eName=Just name})
$ bodyMonthly action
| (Entity name _ action body) <- entities ]
result <- sequence [ runRWST monthAction
(Env ledger allAccounts date () Nothing) ()
| date <- range times ]
ledger' <- lunsafeFix ledger
return $ FullLedger ledger' allAccounts
withRWT :: (r' -> r) -> RWST r w () m a -> RWST r' w () m a
withRWT f = withRWST $ \r s -> (f r,())
evalRWT :: Monad m => RWST r () () m a -> r -> m a
evalRWT action env = liftM fst $ evalRWST action env ()
checkTransactionalAcountSymmetry :: (Monoid w, Ledger l) => [EntityName] -> Acc s l w ()
checkTransactionalAcountSymmetry entities = do
let pairs = [ FAN e1 e2 | e1:rest <- tails entities, e2 <- rest ]
cb = currentBalance . UNSAFE_AccountN
date <- reader eDate
forM_ pairs $ \p -> do
v1 <- cb p
v2 <- negate <$> cb (swapFAN p)
when (v1 /= v2) $ lift $ printf
"symmtery violation at %v: %s %v /= %s %v\n"
date (show p) v1 (show $ swapFAN p) v2
readBody :: Monoid w => (s -> a) -> Acc s l w a
readBody f = reader $ f . eBody
withBody :: Monoid w => (s -> Acc s l w a) -> Acc s l w a
withBody = (reader eBody >>=)