module Penny.Denver.Selloff (main) where
import Control.Arrow (first)
import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (when)
import qualified Control.Monad.Trans.Either as Ei
import qualified Control.Monad.Trans.State as St
import Control.Monad.Trans.Class (lift)
import Data.List (find)
import Data.Maybe (isJust, mapMaybe, catMaybes, fromMaybe)
import Data.Text (pack)
import qualified Data.Text as X
import qualified Data.Text.IO as TIO
import qualified Penny.Lincoln.Balance as Bal
import qualified Data.Sums as S
import qualified Penny.Cabin.Balance.Util as BU
import Penny.Cabin.Options (ShowZeroBalances(..))
import qualified Penny.Copper as Cop
import qualified Penny.Copper.Parsec as CP
import qualified Penny.Copper.Render as CR
import qualified Penny.Liberty as Ly
import qualified Penny.Lincoln as L
import qualified Data.Map as M
import qualified System.Console.MultiArg as MA
import qualified Text.Parsec as Parsec
import qualified Paths_penny as PPB
import qualified Penny as P
type Err = Either Error
data Error
= ParseFail MA.Error
| NoInputArgs
| ProceedsParseFailed Parsec.ParseError
| NoSelloffAccount
| NotThreeSelloffSubAccounts
| BadSelloffBalance
| BadPurchaseBalance
| BadPurchaseDate Parsec.ParseError
| NotThreePurchaseSubAccounts [L.SubAccount]
| BasisAllocationFailed
| ZeroCostSharesSold
| InsufficientSharePurchases
| NoPurchaseInformation
| SaleDateParseFailed Parsec.ParseError
deriving Show
data ProceedsAcct = ProceedsAcct { _unProceedsAcct :: L.Account }
deriving Show
newtype InputFilename = InputFilename { _unInputFilename :: String }
deriving (Eq, Show)
data ParseResult = ParseResult ProceedsAcct [Cop.LedgerItem]
parseCommandLine :: IO ParseResult
parseCommandLine = do
as <- MA.simpleHelpVersion help (Ly.version PPB.version)
[] MA.Intersperse return
x:xs <- case as of
[] -> fail (show NoInputArgs)
r -> return r
a <- either (fail . show . ProceedsParseFailed) return
$ Parsec.parse CP.lvl1Acct "" (pack x)
l <- Cop.open xs
return $ ParseResult (ProceedsAcct a) l
help :: String -> String
help pn = unlines
[ "usage: " ++ pn ++ " PROCEEDS_ACCOUNT FILE..."
, "calculate capital gains and losses from commodity sales."
, "Options:"
, " -h, --help - show this help and exit."
, " --version - show version and exit."
]
calcBalances :: [Cop.LedgerItem] -> [(L.Account, L.Balance)]
calcBalances
= BU.flatten
. BU.balances (ShowZeroBalances False)
. map (\p -> ((), p))
. concatMap L.transactionToPostings
. mapMaybe (S.caseS4 Just (const Nothing) (const Nothing)
(const Nothing))
newtype Group = Group { unGroup :: L.SubAccount }
deriving (Show, Eq)
newtype SaleDate = SaleDate { unSaleDate :: L.DateTime }
deriving (Show, Eq)
newtype SelloffStock = SelloffStock { unSelloffStock :: L.Amount L.Qty }
deriving (Show, Eq)
newtype SelloffCurrency
= SelloffCurrency { unSelloffCurrency :: L.Amount L.Qty }
deriving (Show, Eq)
data SelloffInfo = SelloffInfo
{ siGroup :: Group
, siSaleDate :: SaleDate
, siStock :: SelloffStock
, siCurrency :: SelloffCurrency
} deriving Show
selloffInfo
:: ProceedsAcct -> [(L.Account, L.Balance)] -> Err SelloffInfo
selloffInfo (ProceedsAcct pa) bals = do
bal <- fmap snd
. maybe (Left NoSelloffAccount) Right
. find ((== pa) . fst)
$ bals
(g, d) <- case L.unAccount pa of
_ : s2 : s3 : [] -> return (s2, s3)
_ -> Left NotThreeSelloffSubAccounts
(sStock, sCurr) <- selloffStockCurr bal
date <- fmap SaleDate
. either (Left . SaleDateParseFailed) Right
. Parsec.parse CP.dateTime ""
$ (L.text d)
return $ SelloffInfo (Group g) date sStock sCurr
selloffStockCurr :: L.Balance -> Err (SelloffStock, SelloffCurrency)
selloffStockCurr bal = do
let m = L.unBalance bal
when (M.size m /= 2) $ Left BadSelloffBalance
let toPair (cy, bl) = case bl of
Bal.Zero -> Nothing
Bal.NonZero col -> Just (cy, col)
ps = mapMaybe toPair . M.toList $ m
findBal dc = maybe (Left BadSelloffBalance) Right
. find ((== dc) . Bal.colDrCr . snd)
$ ps
(cyStock, (Bal.Column _ qtyStock)) <- findBal L.Debit
(cyCurr, (Bal.Column _ qtyCurr)) <- findBal L.Credit
let sellStock = SelloffStock
(L.Amount qtyStock cyStock)
sellCurr = SelloffCurrency
(L.Amount qtyCurr cyCurr)
return (sellStock, sellCurr)
basis :: L.SubAccount
basis = L.SubAccount . pack $ "Basis"
findBasisAccounts
:: Group
-> [(L.Account, L.Balance)]
-> [([L.SubAccount], L.Balance)]
findBasisAccounts (Group g) = mapMaybe f
where
f ((L.Account a), b) = case a of
s0 : s1 : s2 : ss -> if (s0 == basis) && (s1 == g)
then Just (s2:ss, b) else Nothing
_ -> Nothing
data PurchaseDate = PurchaseDate { unPurchaseDate :: L.DateTime }
deriving Show
data PurchaseStockQty
= PurchaseStockQty { unPurchaseStockQty :: L.Qty }
deriving (Eq, Show)
data PurchaseCurrencyQty
= PurchaseCurrencyQty { unPurchaseCurrencyQty :: L.Qty }
deriving (Eq, Show)
data PurchaseInfo = PurchaseInfo
{ piDate :: PurchaseDate
, piStockQty :: PurchaseStockQty
, piCurrencyQty :: PurchaseCurrencyQty
} deriving Show
purchaseInfo
:: SelloffStock
-> SelloffCurrency
-> ([L.SubAccount], L.Balance)
-> Err PurchaseInfo
purchaseInfo sStock sCurr (ss, bal) = do
dateSub <- case ss of
s1:[] -> return s1
_ -> Left $ NotThreePurchaseSubAccounts ss
date <- either (Left . BadPurchaseDate) Right
. Parsec.parse CP.dateTime ""
. L.text
$ dateSub
(stockQty, currQty) <- purchaseQtys sStock sCurr bal
return $ PurchaseInfo (PurchaseDate date) stockQty currQty
purchaseQtys
:: SelloffStock
-> SelloffCurrency
-> L.Balance
-> Err (PurchaseStockQty, PurchaseCurrencyQty)
purchaseQtys (SelloffStock sStock) (SelloffCurrency sCurr) bal = do
let m = L.unBalance bal
when (M.size m /= 2) $ Left BadPurchaseBalance
let toPair (cy, bl) = case bl of
Bal.Zero -> Nothing
Bal.NonZero col -> Just (cy, col)
ps = mapMaybe toPair . M.toList $ m
findBal dc = maybe (Left BadPurchaseBalance) Right
. find ((== dc) . Bal.colDrCr . snd)
$ ps
(cyStock, (Bal.Column _ qtyStock)) <- findBal L.Credit
(cyCurr, (Bal.Column _ qtyCurr)) <- findBal L.Debit
when (cyStock /= L.commodity sStock) $ Left BadPurchaseBalance
when (cyCurr /= L.commodity sCurr) $ Left BadPurchaseBalance
return (PurchaseStockQty qtyStock, PurchaseCurrencyQty qtyCurr)
newtype RealizedStockQty
= RealizedStockQty { unRealizedStockQty :: L.Qty }
deriving (Eq, Show)
newtype RealizedCurrencyQty
= RealizedCurrencyQty { unRealizedCurrencyQty :: L.Qty }
deriving (Eq, Show)
newtype CostSharesSold
= CostSharesSold { unCostSharesSold :: L.Qty }
deriving (Eq, Show)
newtype StillToRealize
= StillToRealize { _unStillToRealize :: L.Qty }
deriving (Eq, Show)
data BasisRealiztn = BasisRealiztn
{ brStockQty :: RealizedStockQty
, brCurrencyQty :: RealizedCurrencyQty
} deriving Show
stRealizeBasis
:: PurchaseInfo
-> Ei.EitherT Error
(St.State (Maybe CostSharesSold, Maybe StillToRealize))
(Maybe (PurchaseInfo, BasisRealiztn))
stRealizeBasis p = do
mayTr <- lift $ St.gets snd
case mayTr of
Nothing -> return Nothing
Just (StillToRealize tr) -> do
let sq = unPurchaseStockQty . piStockQty $ p
pcq = unPurchaseCurrencyQty . piCurrencyQty $ p
mayCss <- lift $ St.gets fst
case L.difference tr sq of
L.LeftBiggerBy tr' -> do
let br = BasisRealiztn (RealizedStockQty sq)
(RealizedCurrencyQty pcq)
css' = case mayCss of
Nothing -> CostSharesSold pcq
Just (CostSharesSold css) ->
CostSharesSold (L.add pcq css)
lift $ St.put (Just css', Just (StillToRealize tr'))
return (Just (p, br))
L.RightBiggerBy unsoldStockQty -> do
let alloced = L.allocate pcq (sq, [unsoldStockQty])
basisSold = case alloced of
(x, (_ : [])) -> x
_ -> error "stRealizeBasis: error"
let css' = case mayCss of
Nothing -> CostSharesSold basisSold
Just (CostSharesSold css) ->
CostSharesSold (L.add basisSold css)
br = BasisRealiztn (RealizedStockQty tr)
(RealizedCurrencyQty basisSold)
lift $ St.put (Just css', Nothing)
return (Just (p, br))
L.Equal -> do
let br = BasisRealiztn (RealizedStockQty sq)
(RealizedCurrencyQty pcq)
css' = case mayCss of
Nothing -> CostSharesSold pcq
Just (CostSharesSold css) ->
CostSharesSold (L.add css pcq)
lift $ St.put (Just css', Nothing)
return (Just (p, br))
realizeBases
:: SelloffStock
-> [PurchaseInfo]
-> Err ([(PurchaseInfo, BasisRealiztn)], CostSharesSold)
realizeBases sellStck ps = do
let stReal = Just . StillToRealize . L.qty
. unSelloffStock $ sellStck
(exRs, (mayCss, mayTr)) = St.runState
(Ei.runEitherT (mapM stRealizeBasis ps))
(Nothing, stReal)
rs <- exRs
when (isJust mayTr) $ Left InsufficientSharePurchases
css <- maybe (Left ZeroCostSharesSold) Right mayCss
return (catMaybes rs, css)
newtype CapitalChange = CapitalChange { unCapitalChange :: L.Qty }
deriving Show
data WithCapitalChanges
= WithCapitalChanges [(PurchaseInfo, BasisRealiztn, CapitalChange)]
GainOrLoss
| NoChange [(PurchaseInfo, BasisRealiztn)]
deriving Show
data GainOrLoss = Gain | Loss deriving (Eq, Show)
capitalChange
:: CostSharesSold
-> SelloffCurrency
-> [(PurchaseInfo, BasisRealiztn)]
-> Err WithCapitalChanges
capitalChange css sc ls =
let sellCurrQty = L.qty . unSelloffCurrency $ sc
costQty = unCostSharesSold css
mayGainLoss =
case L.difference sellCurrQty costQty of
L.LeftBiggerBy q -> Just (q, Gain)
L.RightBiggerBy q -> Just (q, Loss)
L.Equal -> Nothing
in case mayGainLoss of
Nothing -> return . NoChange $ ls
Just (qt, gl) -> do
nePurchs <- maybe (Left NoPurchaseInformation) Right
. uncons $ ls
let qtys = mapNE (unPurchaseCurrencyQty . piCurrencyQty . fst)
nePurchs
alloced = L.allocate qt qtys
let mkCapChange (p, br) q = (p, br, CapitalChange q)
r = flattenNE $ zipNE mkCapChange nePurchs alloced
return $ WithCapitalChanges r gl
mapNE :: (a -> b) -> (a, [a]) -> (b, [b])
mapNE f (a, as) = (f a, map f as)
flattenNE :: (a, [a]) -> [a]
flattenNE (a, as) = a:as
uncons :: [a] -> Maybe (a, [a])
uncons as = case as of
[] -> Nothing
x:xs -> Just (x, xs)
zipNE :: (a -> b -> c) -> (a, [a]) -> (b, [b]) -> (c, [c])
zipNE f (a, as) (b, bs) = (f a b, zipWith f as bs)
memo :: SaleDate -> L.Memo
memo (SaleDate sd) =
let dTxt = CR.dateTime sd
txt = pack "transaction created by penny-selloff for sale on "
`X.append` dTxt
in L.Memo [txt]
payee :: L.Payee
payee = L.Payee . pack $ "Realize gain or loss"
topLine :: SaleDate -> L.TopLineData
topLine sd =
let core = (L.emptyTopLineCore (unSaleDate sd))
{ L.tPayee = Just payee
, L.tMemo = Just . memo $ sd
}
in L.TopLineData { L.tlCore = core
, L.tlFileMeta = Nothing
, L.tlGlobal = Nothing }
basisOffsets
:: SelloffInfo
-> PurchaseDate
-> BasisRealiztn
-> ((L.Entry L.Qty, L.PostingData), (L.Entry L.Qty, L.PostingData))
basisOffsets s pd p = (po enDr, po enCr)
where
ac = L.Account [basis, grp, dt]
grp = unGroup . siGroup $ s
dt = dateToSubAcct . unPurchaseDate $ pd
enDr = L.Entry L.Debit
(L.Amount (unRealizedStockQty . brStockQty $ p)
(L.commodity . unSelloffStock . siStock $ s))
enCr = L.Entry L.Credit
(L.Amount (unRealizedCurrencyQty . brCurrencyQty $ p)
(L.commodity . unSelloffCurrency . siCurrency $ s))
po en = (en, emptyPostingData ac)
emptyPostingData :: L.Account -> L.PostingData
emptyPostingData a =
let core = (L.emptyPostingCore a)
{ L.pSide = Just L.CommodityOnLeft
, L.pSpaceBetween = Just L.SpaceBetween
}
in L.PostingData { L.pdCore = core
, L.pdFileMeta = Nothing
, L.pdGlobal = Nothing
}
dateToSubAcct :: L.DateTime -> L.SubAccount
dateToSubAcct = L.SubAccount . CR.dateTime
income :: L.SubAccount
income = L.SubAccount . pack $ "Income"
capGain :: L.SubAccount
capGain = L.SubAccount . pack $ "Capital Gain"
expense :: L.SubAccount
expense = L.SubAccount . pack $ "Expenses"
capLoss :: L.SubAccount
capLoss = L.SubAccount . pack $ "Capital Loss"
capChangeAcct
:: GainOrLoss
-> SelloffInfo
-> PurchaseInfo
-> L.Account
capChangeAcct gl si p = L.Account $ case gl of
Gain -> [income, capGain, grp, sd, pd]
Loss -> [expense, capLoss, grp, sd, pd]
where
grp = unGroup . siGroup $ si
sd = dateToSubAcct . unSaleDate . siSaleDate $ si
pd = dateToSubAcct . unPurchaseDate . piDate $ p
capChangeEntry
:: GainOrLoss
-> SelloffCurrency
-> CapitalChange
-> L.Entry L.Qty
capChangeEntry gl sc cc = L.Entry dc (L.Amount qt cy)
where
dc = case gl of
Gain -> L.Credit
Loss -> L.Debit
cy = L.commodity . unSelloffCurrency $ sc
qt = unCapitalChange cc
capChangePstg
:: SelloffInfo
-> GainOrLoss
-> CapitalChange
-> PurchaseInfo
-> (L.Entry L.Qty, L.PostingData)
capChangePstg si gl cc p = (en, emptyPostingData ac)
where
ac = capChangeAcct gl si p
en = capChangeEntry gl (siCurrency si) cc
proceeds :: L.SubAccount
proceeds = L.SubAccount . pack $ "Proceeds"
proceedsPstgs
:: SelloffInfo
-> ((L.Entry L.Qty, L.PostingData), (L.Entry L.Qty, L.PostingData))
proceedsPstgs si = (po dr, po cr)
where
po en = (en, emptyPostingData ac)
ac = L.Account [proceeds, gr, dt]
gr = unGroup . siGroup $ si
dt = dateToSubAcct . unSaleDate . siSaleDate $ si
dr = L.Entry L.Debit (unSelloffCurrency . siCurrency $ si)
cr = L.Entry L.Credit (unSelloffStock . siStock $ si)
mkTxn
:: SelloffInfo
-> WithCapitalChanges
-> L.Transaction
mkTxn si wcc = fromMaybe err exTxn
where
err = error "mkTxn: making transaction failed"
exTxn = (\topl es -> L.Transaction (topl, es))
<$> pure tl <*> L.ents entInputs
tl = topLine . siSaleDate $ si
(p1, p2) = proceedsPstgs si
ps = case wcc of
NoChange infoRlzns -> concatMap f infoRlzns
where
f (p, br) =
let (b1, b2) = basisOffsets si (piDate p) br
in [b1, b2]
WithCapitalChanges trips gl -> concatMap f trips
where
f (p, br, cc) = [b1, b2, c]
where
(b1, b2) = basisOffsets si (piDate p) br
c = capChangePstg si gl cc p
entInputs = map (first (Just . Right)) (p1:p2:ps)
makeOutput
:: ProceedsAcct
-> [Cop.LedgerItem]
-> Err X.Text
makeOutput pa ldgr = do
let bals = calcBalances ldgr
formatter = P.getQtyFormat defaultRadGroup ldgr
si <- selloffInfo pa bals
let basisAccts = findBasisAccounts (siGroup si) bals
purchInfos <- mapM (purchaseInfo (siStock si) (siCurrency si))
basisAccts
(purchBases, css) <- realizeBases (siStock si) purchInfos
wcc <- capitalChange css (siCurrency si) purchBases
return
. (`X.snoc` '\n')
. fromMaybe (error "makeOutput: transaction did not render")
. (CR.transaction (Just formatter))
. (\t -> let (tl, es) = L.unTransaction t
in (L.tlCore tl, fmap L.pdCore es))
. mkTxn si
$ wcc
main :: IO ()
main = parseCommandLine >>= handleParseResult
handleParseResult :: ParseResult -> IO ()
handleParseResult (ParseResult pa ldgr) =
either (error . show) TIO.putStr . makeOutput pa $ ldgr
defaultRadGroup :: S.S3 L.Radix L.PeriodGrp L.CommaGrp
defaultRadGroup = S.S3a L.Period