module Penny.Cabin.Posts
( postsReport
, zincReport
, defaultOptions
, ZincOpts(..)
, A.Alloc
, A.SubAccountLength(..)
, A.alloc
, yearMonthDay
, qtyAsIs
, balanceAsIs
, defaultWidth
, columnsVarToWidth
, widthFromRuntime
, defaultFields
, defaultSpacerWidth
, T.ReportWidth(..)
) where
import Control.Applicative ((<$>), (<*>))
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Either as Ei
import qualified Data.Text as X
import qualified Penny.Cabin.Interface as I
import qualified Penny.Cabin.Options as CO
import qualified Penny.Cabin.Posts.Allocated as A
import qualified Penny.Cabin.Posts.Chunk as C
import qualified Penny.Cabin.Posts.Fields as F
import qualified Penny.Cabin.Posts.Meta as M
import Penny.Cabin.Posts.Meta (Box)
import qualified Penny.Cabin.Posts.Parser as P
import qualified Penny.Cabin.Posts.Spacers as S
import qualified Penny.Cabin.Posts.Types as T
import qualified Penny.Cabin.Scheme as E
import qualified Penny.Lincoln as L
import qualified Penny.Lincoln.Queries as Q
import qualified Penny.Liberty as Ly
import qualified Penny.Shield as Sh
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import qualified Data.Foldable as Fdbl
import Data.Time as Time
import qualified System.Console.MultiArg as MA
import System.Locale (defaultTimeLocale)
import Text.Matchers.Text (CaseSensitive)
postsReport ::
CO.ShowZeroBalances
-> (L.Box Ly.LibertyMeta -> Bool)
-> [Ly.PostFilterFn]
-> C.ChunkOpts
-> [L.Box Ly.LibertyMeta]
-> [E.PreChunk]
postsReport szb pdct pff co =
C.makeChunk co
. M.toBoxList szb pdct pff
zincReport :: ZincOpts -> I.Report
zincReport opts rt = (helpStr opts, md)
where
md cs fty fsf = MA.Mode
{ MA.mName = "postings"
, MA.mIntersperse = MA.Intersperse
, MA.mOpts = map (fmap Right) (P.allSpecs rt)
, MA.mPosArgs = Left
, MA.mProcess = process opts cs fty fsf
}
process
:: ZincOpts
-> CaseSensitive
-> L.Factory
-> ([L.Transaction] -> [L.Box Ly.LibertyMeta])
-> [Either String (P.State -> Ex.Exceptional String P.State)]
-> Ex.Exceptional String (Either I.HelpStr I.ArgsAndReport)
process os cs fty fsf ls =
let (posArgs, clOpts) = Ei.partitionEithers ls
pState = newParseState cs fty os
exState' = foldl (>>=) (return pState) clOpts
in fmap (mkPrintReport posArgs os fsf) exState'
mkPrintReport
:: [String]
-> ZincOpts
-> ([L.Transaction] -> [L.Box Ly.LibertyMeta])
-> P.State
-> Either I.HelpStr I.ArgsAndReport
mkPrintReport posArgs zo fsf st = r
where
r = if P.showHelp st then Left $ helpStr zo else Right pr
pr = (posArgs, f)
f txns _ = fmap mkChunks exPdct
where
exPdct = getPredicate (P.tokens st)
mkChunks pdct = chks
where
chks = postsReport (P.showZeroBalances st) pdct
(P.postFilter st) (chunkOpts st zo) boxes
boxes = fsf txns
defaultOptions
:: Sh.Runtime
-> ZincOpts
defaultOptions rt = ZincOpts
{ fields = defaultFields
, width = widthFromRuntime rt
, showZeroBalances = CO.ShowZeroBalances False
, dateFormat = yearMonthDay
, qtyFormat = qtyAsIs
, balanceFormat = balanceAsIs
, subAccountLength = A.SubAccountLength 2
, payeeAllocation = A.alloc 60
, accountAllocation = A.alloc 40
, spacers = defaultSpacerWidth }
getPredicate ::
[Ly.Token (L.Box Ly.LibertyMeta -> Bool)]
-> Ex.Exceptional X.Text (L.Box Ly.LibertyMeta -> Bool)
getPredicate ts =
case ts of
[] -> return $ const True
ls ->
Ex.fromMaybe
(X.pack "posts report: bad posting filter expression")
(Ly.parseTokenList ls)
data ZincOpts = ZincOpts
{ fields :: F.Fields Bool
, width :: T.ReportWidth
, showZeroBalances :: CO.ShowZeroBalances
, dateFormat :: Box -> X.Text
, qtyFormat :: Box -> X.Text
, balanceFormat :: L.Commodity -> L.Qty -> X.Text
, subAccountLength :: A.SubAccountLength
, payeeAllocation :: A.Alloc
, accountAllocation :: A.Alloc
, spacers :: S.Spacers Int
}
chunkOpts ::
P.State
-> ZincOpts
-> C.ChunkOpts
chunkOpts s z = C.ChunkOpts
{ C.dateFormat = dateFormat z
, C.qtyFormat = qtyFormat z
, C.balanceFormat = balanceFormat z
, C.fields = P.fields s
, C.subAccountLength = subAccountLength z
, C.payeeAllocation = payeeAllocation z
, C.accountAllocation = accountAllocation z
, C.spacers = spacers z
, C.reportWidth = P.width s
}
newParseState ::
CaseSensitive
-> L.Factory
-> ZincOpts
-> P.State
newParseState cs fty o = P.State
{ P.sensitive = cs
, P.factory = fty
, P.tokens = []
, P.postFilter = []
, P.fields = fields o
, P.width = width o
, P.showZeroBalances = showZeroBalances o
, P.showHelp = False
}
yearMonthDay :: Box -> X.Text
yearMonthDay p = X.pack (Time.formatTime defaultTimeLocale fmt d)
where
d = L.day
. Q.dateTime
. L.boxPostFam
$ p
fmt = "%Y-%m-%d"
qtyAsIs :: Box -> X.Text
qtyAsIs p = X.pack . show . Q.qty . L.boxPostFam $ p
balanceAsIs :: a -> L.Qty -> X.Text
balanceAsIs _ = X.pack . show
defaultWidth :: T.ReportWidth
defaultWidth = T.ReportWidth 80
columnsVarToWidth :: Maybe String -> T.ReportWidth
columnsVarToWidth ms = case ms of
Nothing -> defaultWidth
Just str -> case reads str of
[] -> defaultWidth
(i, []):[] -> if i > 0 then T.ReportWidth i else defaultWidth
_ -> defaultWidth
widthFromRuntime :: Sh.Runtime -> T.ReportWidth
widthFromRuntime rt = case Sh.screenWidth rt of
Nothing -> defaultWidth
Just w -> T.ReportWidth . Sh.unScreenWidth $ w
defaultFields :: F.Fields Bool
defaultFields =
F.Fields { F.globalTransaction = False
, F.revGlobalTransaction = False
, F.globalPosting = False
, F.revGlobalPosting = False
, F.fileTransaction = False
, F.revFileTransaction = False
, F.filePosting = False
, F.revFilePosting = False
, F.filtered = False
, F.revFiltered = False
, F.sorted = False
, F.revSorted = False
, F.visible = False
, F.revVisible = False
, F.lineNum = False
, F.date = True
, F.flag = False
, F.number = False
, F.payee = True
, F.account = True
, F.postingDrCr = True
, F.postingCmdty = True
, F.postingQty = True
, F.totalDrCr = True
, F.totalCmdty = True
, F.totalQty = True
, F.tags = False
, F.memo = False
, F.filename = False }
defaultSpacerWidth :: S.Spacers Int
defaultSpacerWidth =
S.Spacers { S.globalTransaction = 1
, S.revGlobalTransaction = 1
, S.globalPosting = 1
, S.revGlobalPosting = 1
, S.fileTransaction = 1
, S.revFileTransaction = 1
, S.filePosting = 1
, S.revFilePosting = 1
, S.filtered = 1
, S.revFiltered = 1
, S.sorted = 1
, S.revSorted = 1
, S.visible = 1
, S.revVisible = 1
, S.lineNum = 1
, S.date = 1
, S.flag = 1
, S.number = 1
, S.payee = 4
, S.account = 1
, S.postingDrCr = 1
, S.postingCmdty = 1
, S.postingQty = 1
, S.totalDrCr = 1
, S.totalCmdty = 1 }
ifDefault :: Bool -> String
ifDefault b = if b then " (default)" else ""
bundles :: Int -> [a] -> [[a]]
bundles c ls
| c < 1 = error "bundles: argument must be positive"
| otherwise = case splitAt c ls of
(r, []) -> [r]
(r, rs) -> r : bundles c rs
helpStr :: ZincOpts -> String
helpStr o = unlines $
[ "postings"
, " Show postings in order with a running balance."
, " Accepts the following options:"
, ""
, "Posting filters"
, "==============="
, "These options affect which postings are shown in the report."
, "Postings not shown still affect the running balance."
, ""
, "Dates"
, "-----"
, ""
, "--date cmp timespec, -d cmp timespec"
, " Date must be within the time frame given. timespec"
, " is a day or a day and a time. Valid values for cmp:"
, " <, >, <=, >=, ==, /=, !="
, "--current"
, " Same as \"--date <= (right now) \""
, ""
, "Serials"
, "-------"
, "These options take the form --option cmp num; the given"
, "sequence number must fall within the given range. \"rev\""
, "in the option name indicates numbering is from end to beginning."
, ""
, "--globalTransaction, --revGlobalTransaction"
, " All transactions, after reading the ledger files"
, "--globalPosting, --revGlobalPosting"
, " All postings, after reading the leder files"
, "--fileTransaction, --revFileTransaction"
, " Transactions in each ledger file, after reading the files"
, " (numbering restarts with each file)"
, "--filePosting, --revFilePosting"
, " Postings in each ledger file, after reading the files"
, " (numbering restarts with each file)"
, "--filtered, --revFiltered"
, " All postings, after filters given in the filter"
, " specification portion of the command line are"
, " applied"
, "--sorted, --revSorted"
, " All postings remaining after filtering and after"
, " postings have been sorted"
, ""
, "Pattern matching"
, "----------------"
, ""
, "-a pattern, --account pattern"
, " Pattern must match colon-separated account name"
, "--account-level num pat"
, " Pattern must match sub account at given level"
, "--account-any pat"
, " Pattern must match sub account at any level"
, "-p pattern, --payee pattern"
, " Payee must match pattern"
, "-t pattern, --tag pattern"
, " Tag must match pattern"
, "--number pattern"
, " Number must match pattern"
, "--flag pattern"
, " Flag must match pattern"
, "--commodity pattern"
, " Pattern must match colon-separated commodity name"
, "--posting-memo pattern"
, " Posting memo must match pattern"
, "--transaction-memo pattern"
, " Transaction memo must match pattern"
, ""
, "Other posting characteristics"
, "-----------------------------"
, "--debit"
, " Entry must be a debit"
, "--credit"
, " Entry must be a credit"
, "--qty cmp number"
, " Entry quantity must fall within given range"
, ""
, "Operators - from highest to lowest precedence"
, "(all are left associative)"
, "=========================="
, "--open expr --close"
, " Force precedence (as in \"open\" and \"close\" parentheses)"
, "--not expr"
, " True if expr is false"
, "expr1 --and expr2 "
, " True if expr and expr2 are both true"
, "expr1 --or expr2"
, " True if either expr1 or expr2 is true"
, ""
, "Options affecting patterns"
, "=========================="
, ""
, "-i, --case-insensitive"
, " Be case insensitive"
, "-I, --case-sensitive"
, " Be case sensitive"
, ""
, "--within"
, " Use \"within\" matcher"
, "--pcre"
, " Use \"pcre\" matcher"
, "--posix"
, " Use \"posix\" matcher"
, "--exact"
, " Use \"exact\" matcher"
, ""
, "Removing postings after sorting and filtering"
, "============================================="
, "--head n"
, " Keep only the first n postings"
, "--tail n"
, " Keep only the last n postings"
, ""
, "Other options"
, "============="
, "--width num"
, " Hint for roughly how wide the report should be in columns"
, " (currently: " ++ (show . T.unReportWidth . width $ o) ++ ")"
, "--show field, --hide field"
, " show or hide this field, where field is one of:"
, " globalTransaction, revGlobalTransaction,"
, " globalPosting, revGlobalPosting,"
, " fileTransaction, revFileTransaction,"
, " filePosting, revFilePosting,"
, " filtered, revFiltered,"
, " sorted, revSorted,"
, " visible, revVisible,"
, " lineNum,"
, " date, flag, number, payee, account,"
, " postingDrCr, postingCommodity, postingQty,"
, " totalDrCr, totalCommodity, totalQty,"
, " tags, memo, filename"
, "--show-all"
, " Show all fields"
, "--hide-all"
, " Hide all fields"
, ""
] ++ showDefaultFields (fields o) ++
[ ""
, "--show-zero-balances"
, " Show balances that are zero"
++ ifDefault (CO.unShowZeroBalances . showZeroBalances $ o)
, "--hide-zero-balances"
, " Hide balances that are zero"
++ ifDefault (not . CO.unShowZeroBalances . showZeroBalances $ o)
, ""
, "--help, -h"
, " Show this help and exit"
]
showDefaultFields :: F.Fields Bool -> [String]
showDefaultFields i = hdr : rest
where
hdr = "Fields shown by default:"
++ if null rest then " (none)" else ""
rest =
map (" " ++)
. map concat
. map (intersperse ", ")
. bundles 3
. catMaybes
. Fdbl.toList
. toMaybes
$ i
toMaybes flds = f <$> flds <*> F.fieldNames
f b n = if b then Just n else Nothing