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 Data.List.Split (chunksOf)
import qualified Data.Either as Ei
import Data.Monoid ((<>))
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 qualified Penny.Steel.Expressions as Exp
import qualified Penny.Steel.Pdct as Pe
import qualified Penny.Steel.Chunk as Chk
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 (CaseSensitive)
postsReport ::
CO.ShowZeroBalances
-> (Pe.Pdct (L.Box Ly.LibertyMeta))
-> [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 expr fsf = MA.Mode
{ MA.mName = "postings"
, MA.mIntersperse = MA.Intersperse
, MA.mOpts = specs rt
, MA.mPosArgs = Left
, MA.mProcess = process opts cs fty expr fsf
, MA.mHelp = const (helpStr opts)
}
specs
:: Sh.Runtime
-> [MA.OptSpec (Either String (P.State -> Ex.Exceptional X.Text P.State))]
specs = map (fmap Right) . P.allSpecs
process
:: ZincOpts
-> CaseSensitive
-> L.Factory
-> Exp.ExprDesc
-> ([L.Transaction] -> [L.Box Ly.LibertyMeta])
-> [Either String (P.State -> Ex.Exceptional X.Text P.State)]
-> Ex.Exceptional X.Text I.ArgsAndReport
process os cs fty expr fsf ls =
let (posArgs, clOpts) = Ei.partitionEithers ls
pState = newParseState cs fty expr os
exState' = foldl (>>=) (return pState) clOpts
in fmap (mkPrintReport posArgs os fsf) exState'
mkPrintReport
:: [String]
-> ZincOpts
-> ([L.Transaction] -> [L.Box Ly.LibertyMeta])
-> P.State
-> I.ArgsAndReport
mkPrintReport posArgs zo fsf st = (posArgs, f)
where
f txns _ = do
pdct <- getPredicate (P.exprDesc st) (P.tokens st)
let boxes = fsf txns
rptChks = postsReport (P.showZeroBalances st) pdct
(P.postFilter st) (chunkOpts st zo) boxes
expChks = showExpression (P.showExpression st) pdct
verbChks = showVerboseFilter (P.verboseFilter st) pdct boxes
chks = map Left expChks
++ map Left verbChks
++ map Right rptChks
return chks
indentAmt :: Pe.IndentAmt
indentAmt = 4
blankLine :: Chk.Chunk
blankLine = Chk.chunk Chk.defaultTextSpec "\n"
showExpression
:: P.ShowExpression
-> Pe.Pdct (L.Box Ly.LibertyMeta)
-> [Chk.Chunk]
showExpression (P.ShowExpression b) pdct =
if not b then [] else info : blankLine : (chks ++ [blankLine])
where
info = Chk.chunk Chk.defaultTextSpec "Postings filter expression:\n"
chks = Pe.showPdct indentAmt 0 pdct
showVerboseFilter
:: P.VerboseFilter
-> Pe.Pdct (L.Box Ly.LibertyMeta)
-> [L.Box Ly.LibertyMeta]
-> [Chk.Chunk]
showVerboseFilter (P.VerboseFilter b) pdct bs =
if not b then [] else info : blankLine : (chks ++ [blankLine])
where
pdcts = map (makeLabeledPdct pdct) bs
chks = concat . map snd $ zipWith doEval bs pdcts
doEval subj pd = Pe.evaluate indentAmt False subj 0 pd
info = Chk.chunk Chk.defaultTextSpec "Postings report filter:\n"
makeLabeledPdct
:: Pe.Pdct (L.Box Ly.LibertyMeta)
-> L.Box Ly.LibertyMeta
-> Pe.Pdct (L.Box Ly.LibertyMeta)
makeLabeledPdct pd box = Pe.rename f pd
where
f old = old <> " - " <> L.display pf
pf = L.boxPostFam box
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
}
type Error = X.Text
getPredicate
:: Exp.ExprDesc
-> [Exp.Token (L.Box Ly.LibertyMeta)]
-> Ex.Exceptional Error (Pe.Pdct (L.Box Ly.LibertyMeta))
getPredicate d ts =
case ts of
[] -> return $ Pe.always
_ -> Exp.parseExpression d ts
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
-> Exp.ExprDesc
-> ZincOpts
-> P.State
newParseState cs fty expr 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.exprDesc = expr
, P.verboseFilter = P.VerboseFilter False
, P.showExpression = P.ShowExpression 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 ""
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"
, ""
, "Infix or RPN selection"
, "----------------------"
, "--infix - use infix notation"
, "--rpn - use reverse polish notation"
, " (default: use what was used in the filtering options)"
, ""
, "Infix 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"
, ""
, "RPN Operators"
, "-------------"
, "expr --not"
, " True if expr is false"
, "expr1 expr2 --and"
, " True if expr and expr2 are both true"
, "expr1 expr2 --or"
, " 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 ", ")
. chunksOf 3
. catMaybes
. Fdbl.toList
. toMaybes
$ i
toMaybes flds = f <$> flds <*> F.fieldNames
f b n = if b then Just n else Nothing