module Penny.Brenner.Clear (mode) where
import Control.Applicative
import Control.Monad (guard, mzero, when)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Monoid (mconcat, First(..))
import qualified Data.Set as Set
import qualified Data.Map as M
import qualified Data.Text as X
import qualified Data.Traversable as Tr
import qualified System.Console.MultiArg as MA
import qualified Penny.Lincoln as L
import qualified Penny.Liberty as Ly
import qualified Data.Sums as S
import qualified Control.Monad.Trans.State as St
import qualified Control.Monad.Trans.Maybe as MT
import Control.Monad.Trans.Class (lift)
import qualified Penny.Copper as C
import qualified Penny.Copper.Render as R
import Text.Show.Pretty (ppShow)
import qualified Penny.Brenner.Types as Y
import qualified Penny.Brenner.Util as U
help :: String -> String
help pn = unlines
[ "usage: " ++ pn ++ " clear [options] FIT_FILE LEDGER_FILE..."
, "Parses all postings that are in FIT_FILE. Then marks all"
, "postings that are in the FILEs given that correspond to one"
, "of the postings in the FIT_FILE as being cleared."
, "Quits if one of the postings found in FIT_FILE is not found"
, "in the database, if one of the postings in the database"
, "is not found in one of the FILEs, or if any of the postings found"
, "in one of the FILEs already has a flag."
, ""
, "Results are printed to standard output. If no FILE, or FILE is \"-\","
, "read standard input."
, ""
, "Options:"
, " -o, --output FILENAME - send output to FILENAME"
, " (default: send to standard output)"
, " -h, --help - show help and exit"
]
data Arg
= APosArg String
| AOutput (X.Text -> IO ())
toPosArg :: Arg -> Maybe String
toPosArg a = case a of { APosArg s -> Just s; _ -> Nothing }
toOutput :: Arg -> Maybe (X.Text -> IO ())
toOutput a = case a of { AOutput x -> Just x; _ -> Nothing }
data Opts = Opts
{ csvLocation :: Y.FitFileLocation
, ledgerLocations :: [String]
, printer :: X.Text -> IO ()
}
mode :: Y.Mode
mode mayFa = MA.modeHelp
"clear"
help
(process mayFa)
[fmap AOutput Ly.output]
MA.Intersperse
(return . APosArg)
process :: Maybe Y.FitAcct -> [Arg] -> IO ()
process mayFa as = do
fa <- U.getFitAcct mayFa
(csv, ls) <- case mapMaybe toPosArg as of
[] -> fail "clear: you must provide a postings file."
x:xs -> return (Y.FitFileLocation x, xs)
let os = Opts csv ls (Ly.processOutput . mapMaybe toOutput $ as)
runClear fa os
runClear :: Y.FitAcct -> Opts -> IO ()
runClear c os = do
dbList <- U.loadDb (Y.AllowNew False) (Y.dbLocation c)
let db = M.fromList dbList
(_, prsr) = Y.parser c
txns <- fmap (either fail return) $ prsr (csvLocation os)
leds <- C.open (ledgerLocations os)
toClear <- case mapM (findUNumber db) (concat txns) of
Nothing -> fail $ "at least one posting was not found in the"
++ " database. Ensure all postings have "
++ "been imported and merged."
Just ls -> return $ Set.fromList ls
let (led', left) = changeLedger (Y.pennyAcct c) toClear leds
led'' = map C.stripMeta led'
when (not (Set.null left))
(fail $ "some postings were not cleared. "
++ "Those not cleared:\n" ++ ppShow left)
case mapM (R.item Nothing) led'' of
Nothing ->
fail "could not render resulting ledger."
Just txts ->
let glued = X.concat txts
in glued `seq` printer os glued
findUNumber :: Y.DbMap -> Y.Posting -> Maybe Y.UNumber
findUNumber m pstg =
let atn = Y.fitId pstg
p ap = Y.fitId ap == atn
filteredMap = M.filter p m
ls = M.toList filteredMap
in case ls of
(n, _):[] -> Just n
_ -> Nothing
clearedFlag :: L.Flag
clearedFlag = L.Flag . X.singleton $ 'C'
changeLedger
:: Y.PennyAcct
-> Set.Set Y.UNumber
-> [C.LedgerItem]
-> ([C.LedgerItem], Set.Set Y.UNumber)
changeLedger ax s l = St.runState k s
where
k = mapM f l
f x = case x of
S.S4a t -> fmap S.S4a $ changeTxn ax t
S.S4b z -> fmap S.S4b $ return z
S.S4c z -> fmap S.S4c $ return z
S.S4d z -> fmap S.S4d $ return z
changeTxn
:: Y.PennyAcct
-> L.Transaction
-> St.State (Set.Set Y.UNumber) L.Transaction
changeTxn ax (L.Transaction (tld, d)) =
(\tl es -> L.Transaction (tl, es))
<$> pure tld
<*> Tr.mapM (changePstg ax) d
changePstg
:: Y.PennyAcct
-> L.PostingData
-> St.State (Set.Set Y.UNumber) L.PostingData
changePstg ax p =
fmap (fromMaybe p) . MT.runMaybeT $ do
let c = L.pdCore p
guard (L.pAccount c == (Y.unPennyAcct ax))
let tags = L.pTags c
un <- maybe mzero return $ parseUNumberFromTags tags
guard (L.pFlag c == Nothing)
set <- lift St.get
guard (Set.member un set)
lift $ St.put (Set.delete un set)
let c' = c { L.pFlag = Just clearedFlag }
return $ p { L.pdCore = c' }
parseUNumberFromTags :: L.Tags -> Maybe Y.UNumber
parseUNumberFromTags =
getFirst
. mconcat
. map First
. map parseUNumberFromTag
. L.unTags
parseUNumberFromTag :: L.Tag -> Maybe Y.UNumber
parseUNumberFromTag (L.Tag x) = do
(f, xs) <- X.uncons x
guard (f == 'U')
case reads . X.unpack $ xs of
(u, ""):[] -> Just (Y.UNumber u)
_ -> Nothing