diff --git a/Penny/Cabin.hs b/Penny/Cabin.hs --- a/Penny/Cabin.hs +++ b/Penny/Cabin.hs @@ -11,5 +11,5 @@ -> C.RadGroup -> [I.Report] allReportsWithDefaults dtz rg = - [B.defaultBalanceReport, P.defaultPostsReport dtz rg] - + [ B.balanceReport (B.defaultOptions dtz) + , P.makeReport (P.defaultOptions dtz rg) ] diff --git a/Penny/Cabin/Balance.hs b/Penny/Cabin/Balance.hs --- a/Penny/Cabin/Balance.hs +++ b/Penny/Cabin/Balance.hs @@ -1,21 +1,107 @@ -- | The Penny balance report -module Penny.Cabin.Balance (balanceReport, O.defaultOptions, - O.Options(..), - defaultBalanceReport) where +module Penny.Cabin.Balance ( + -- * Making reports + + -- | Use these functions if you are building a report from your own + -- code and you are not using the Zinc parser. + T.report + , T.nullConvert + , T.converter + + -- * Parsing reports + -- | For use with the Zinc command line parser. + , BalanceOpts(..) + , balanceReport + , defaultOptions + , balanceAsIs + ) where + +import qualified Penny.Cabin.Balance.Tree as T import qualified Penny.Cabin.Balance.Parser as P -import qualified Penny.Cabin.Balance.Options as O import qualified Penny.Cabin.Balance.Help as H +import qualified Penny.Cabin.Chunk as Chunk +import qualified Penny.Cabin.Colors as C +import qualified Penny.Cabin.Colors.DarkBackground as Dark import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Options as CO +import qualified Penny.Copper as Cop +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Balance as Bal import qualified Penny.Shield as S -balanceReport :: (S.Runtime -> O.Options) -> I.Report -balanceReport getOpts = I.Report H.help "balance" pr - where - pr = do - fn <- P.parser - let f rt _ _ bs ps = fn rt (getOpts rt) bs ps - return f +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Text as X +import System.Console.MultiArg.Prim (Parser) -defaultBalanceReport :: I.Report -defaultBalanceReport = balanceReport O.defaultOptions +data BalanceOpts = BalanceOpts { + drCrColors :: C.DrCrColors + , baseColors :: C.BaseColors + , balanceFormat :: L.BottomLine -> X.Text + , colorPref :: Chunk.Colors + , showZeroBalances :: CO.ShowZeroBalances + , defaultTimeZone :: Cop.DefaultTimeZone + , convert :: Maybe (L.Commodity, L.DateTime) + } + +toParseOpts :: BalanceOpts -> P.ParseOpts +toParseOpts b = P.ParseOpts { + P.drCrColors = drCrColors b + , P.baseColors = baseColors b + , P.colorPref = colorPref b + , P.showZeroBalances = showZeroBalances b + , P.convert = convert b + } + +toTreeOpts :: P.ParseOpts -> BalanceOpts -> T.TreeOpts +toTreeOpts p b = T.TreeOpts { + T.drCrColors = P.drCrColors p + , T.baseColors = P.baseColors p + , T.balanceFormat = balanceFormat b + , T.showZeroBalances = P.showZeroBalances p + } + +parser :: (S.Runtime -> BalanceOpts) -> Parser I.ReportFunc +parser frt = do + parsed <- P.parseOptions + let rf rt _ _ ps pps = do + let bo = frt rt + po = toParseOpts bo + po' <- Ex.mapException showParseErr $ + parsed rt (defaultTimeZone bo) po + let to = toTreeOpts po' bo + conv <- case P.convert po' of + Nothing -> return $ T.nullConvert ps + Just co -> T.converter co pps ps + return + . Chunk.chunksToText (P.colorPref po') + . concat + . T.report to + $ conv + return rf + + +showParseErr :: P.Error -> X.Text +showParseErr = X.pack . show + + +balanceReport :: (S.Runtime -> BalanceOpts) -> I.Report +balanceReport f = I.Report H.help "balance" (parser f) + + +defaultOptions :: Cop.DefaultTimeZone -> S.Runtime -> BalanceOpts +defaultOptions dtz rt = BalanceOpts { + drCrColors = Dark.drCrColors + , baseColors = Dark.baseColors + , balanceFormat = balanceAsIs + , colorPref = CO.maxCapableColors rt + , showZeroBalances = CO.ShowZeroBalances False + , defaultTimeZone = dtz + , convert = Nothing + } + +balanceAsIs :: L.BottomLine -> X.Text +balanceAsIs n = case n of + L.Zero -> X.pack "--" + L.NonZero c -> X.pack . show . L.unQty . Bal.qty $ c + diff --git a/Penny/Cabin/Balance/Options.hs b/Penny/Cabin/Balance/Options.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Options.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | Options for the Balance report. -module Penny.Cabin.Balance.Options where - -import qualified Data.Text as X -import qualified Penny.Lincoln as L -import qualified Penny.Cabin.Chunk as Chunk -import qualified Penny.Cabin.Colors as C -import qualified Penny.Cabin.Options as O -import qualified Penny.Shield as S -import qualified Penny.Cabin.Colors.DarkBackground as DB -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Lincoln.Balance as Bal - -data Options = Options { - drCrColors :: C.DrCrColors - , baseColors :: C.BaseColors - , balanceFormat :: L.BottomLine -> X.Text - , colorPref :: Chunk.Colors - , showZeroBalances :: O.ShowZeroBalances - , convert :: Maybe (L.Commodity, L.DateTime) - , defaultTimeZone :: DT.DefaultTimeZone - } - -balanceAsIs :: L.BottomLine -> X.Text -balanceAsIs n = case n of - L.Zero -> X.pack "--" - L.NonZero c -> X.pack . show . L.unQty . Bal.qty $ c - -defaultOptions :: S.Runtime -> Options -defaultOptions rt = Options { - drCrColors = DB.drCrColors - , baseColors = DB.baseColors - , balanceFormat = balanceAsIs - , colorPref = O.maxCapableColors rt - , showZeroBalances = O.ShowZeroBalances False - , convert = Nothing - , defaultTimeZone = DT.utcDefault } diff --git a/Penny/Cabin/Balance/Parser.hs b/Penny/Cabin/Balance/Parser.hs --- a/Penny/Cabin/Balance/Parser.hs +++ b/Penny/Cabin/Balance/Parser.hs @@ -1,52 +1,41 @@ -module Penny.Cabin.Balance.Parser (parser) where +module Penny.Cabin.Balance.Parser ( + Error(..) + , ParseOpts(..) + , parseOptions + ) where import qualified Data.Text as X -import qualified Data.Text.Lazy as XL -import Control.Applicative ((<|>), many) +import Control.Applicative ((<|>), many, Applicative, pure) import Control.Monad ((>=>)) import qualified Control.Monad.Exception.Synchronous as Ex import qualified Penny.Cabin.Colors as Col import qualified Penny.Cabin.Colors.DarkBackground as DB import qualified Penny.Cabin.Colors.LightBackground as LB import qualified Penny.Cabin.Chunk as Chk -import qualified Penny.Cabin.Balance.Options as O -import qualified Penny.Cabin.Balance.Tree as Tree import qualified Penny.Cabin.Options as CO import qualified Penny.Copper.Commodity as CC import qualified Penny.Copper.DateTime as CD -import qualified Penny.Liberty as Ly import qualified Penny.Lincoln as L import qualified Penny.Shield as S import System.Console.MultiArg.Prim (Parser) import qualified System.Console.MultiArg.Combinator as C import qualified Text.Parsec as Parsec +data ParseOpts = ParseOpts { + drCrColors :: Col.DrCrColors + , baseColors :: Col.BaseColors + , colorPref :: Chk.Colors + , showZeroBalances :: CO.ShowZeroBalances + , convert :: Maybe (L.Commodity, L.DateTime) + } + + data Error = BadColorName String | BadBackground String | BadCommodity String | BadDate String deriving Show -parser :: - Parser (S.Runtime - -> O.Options - -> [L.Box Ly.LibertyMeta] - -> [L.PricePoint] - -> Ex.Exceptional X.Text XL.Text) -parser = do - ls <- many opts - let f rt opInit bs ps = do - let ls' = map (\fn -> fn rt) ls - errOpParsed = (foldl (>=>) return ls') opInit - opParsed <- case errOpParsed of - Ex.Exception e -> Ex.throw . X.pack . show $ e - Ex.Success g -> return g - bits <- Tree.report opParsed bs ps - return - . Chk.chunksToText (O.colorPref opParsed) - . concat - $ bits - return f processColorArg :: S.Runtime @@ -63,13 +52,13 @@ parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a] color :: Parser (S.Runtime - -> O.Options - -> Ex.Exceptional Error O.Options) + -> ParseOpts + -> Ex.Exceptional Error ParseOpts) color = parseOpt ["color"] "" (C.OneArg f) where f a1 rt op = case processColorArg rt a1 of Nothing -> Ex.throw . BadColorName $ a1 - Just c -> return (op { O.colorPref = c }) + Just c -> return (op { colorPref = c }) processBackgroundArg :: String @@ -80,47 +69,48 @@ | otherwise = Nothing -background :: Parser (O.Options -> Ex.Exceptional Error O.Options) +background :: Parser (ParseOpts -> Ex.Exceptional Error ParseOpts) background = parseOpt ["background"] "" (C.OneArg f) where f a1 op = case processBackgroundArg a1 of Nothing -> Ex.throw . BadBackground $ a1 Just (dc, base) -> - return op { O.drCrColors = dc - , O.baseColors = base } + return op { drCrColors = dc + , baseColors = base } -showZeroBalances :: - Parser (O.Options -> Ex.Exceptional a O.Options) -showZeroBalances = parseOpt ["show-zero-balances"] "" (C.NoArg f) +parseShowZeroBalances :: Parser (ParseOpts -> ParseOpts) +parseShowZeroBalances = parseOpt opt "" (C.NoArg f) where + opt = ["show-zero-balances"] f op = - return (op {O.showZeroBalances = CO.ShowZeroBalances True }) + op {showZeroBalances = CO.ShowZeroBalances True } -hideZeroBalances :: - Parser (O.Options -> Ex.Exceptional a O.Options) +hideZeroBalances :: Parser (ParseOpts -> ParseOpts) hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f) where f op = - return (op {O.showZeroBalances = CO.ShowZeroBalances False }) + op {showZeroBalances = CO.ShowZeroBalances False } convertLong :: - Parser (O.Options -> Ex.Exceptional Error O.Options) + Parser (CD.DefaultTimeZone + -> ParseOpts + -> Ex.Exceptional Error ParseOpts) convertLong = parseOpt ["convert"] "" (C.TwoArg f) where - f a1 a2 op = do + f a1 a2 dtz op = do cty <- case Parsec.parse CC.lvl1Cmdty "" (X.pack a1) of Left _ -> Ex.throw . BadCommodity $ a1 Right g -> return g - let parseDate = CD.dateTime (O.defaultTimeZone op) + let parseDate = CD.dateTime dtz dt <- case Parsec.parse parseDate "" (X.pack a2) of Left _ -> Ex.throw . BadDate $ a2 Right g -> return g - let op' = op { O.convert = Just (cty, dt) } + let op' = op { convert = Just (cty, dt) } return op' convertShort :: Parser (S.Runtime - -> O.Options - -> Ex.Exceptional Error O.Options) + -> ParseOpts + -> Ex.Exceptional Error ParseOpts) convertShort = parseOpt [] ['c'] (C.OneArg f) where f a1 rt op = do @@ -128,21 +118,39 @@ Left _ -> Ex.throw . BadCommodity $ a1 Right g -> return g let dt = S.currentTime rt - op' = op { O.convert = Just (cty, dt) } + op' = op { convert = Just (cty, dt) } return op' -opts :: Parser (S.Runtime - -> O.Options - -> Ex.Exceptional Error O.Options) -opts = - color - <|> mkTwoArg background - <|> mkTwoArg showZeroBalances - <|> mkTwoArg hideZeroBalances - <|> mkTwoArg convertLong - <|> convertShort +parseOptions :: Parser (S.Runtime + -> CD.DefaultTimeZone + -> ParseOpts + -> Ex.Exceptional Error ParseOpts) +parseOptions = do + fns <- many parseOption + let f rt dtz o1 = + let fns' = map (\fn -> fn rt dtz) fns + in foldl (>=>) return fns' o1 + return f + +parseOption :: Parser (S.Runtime + -> CD.DefaultTimeZone + -> ParseOpts + -> Ex.Exceptional Error ParseOpts) +parseOption = + (do { f <- color; return (\rt _ o -> f rt o )}) + <|> wrap background + <|> wrap (impurify parseShowZeroBalances) + <|> wrap (impurify hideZeroBalances) + <|> (do { f <- convertLong; return (\_ dtz o -> f dtz o )}) + <|> (do { f <- convertShort; return (\rt _ o -> f rt o )}) where - mkTwoArg p = do + wrap p = do f <- p - return (\_ op -> f op) + return (\_ _ op -> f op) + +impurify :: + (Applicative m, Functor f) + => f (a -> a) + -> f (a -> m a) +impurify = fmap (\f -> pure . f) diff --git a/Penny/Cabin/Balance/Tree.hs b/Penny/Cabin/Balance/Tree.hs --- a/Penny/Cabin/Balance/Tree.hs +++ b/Penny/Cabin/Balance/Tree.hs @@ -20,7 +20,13 @@ -- * 8. [Columns PreSpec] -> [Columns R.ColumnSpec] (strict) -- -- * 9. [Columns R.ColumnSpec] -> [[Chunk.Bit]] (lazy) -module Penny.Cabin.Balance.Tree (report) where +module Penny.Cabin.Balance.Tree ( + report + , TreeOpts(..) + , PriceConverteds + , nullConvert + , converter + ) where import Control.Applicative(Applicative(pure, (<*>)), (<$>)) import qualified Control.Monad.Exception.Synchronous as Ex @@ -34,7 +40,6 @@ import qualified Data.Text as X import qualified Data.Traversable as Tr import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Balance.Options as O import qualified Penny.Cabin.Chunk as Chunk import qualified Penny.Cabin.Colors as C import qualified Penny.Liberty as Ly @@ -44,10 +49,14 @@ import qualified Data.Semigroup as S -- Step 1. Convert prices. + data PriceConverted = PriceConverted { pcEntry :: L.Entry , pcAccount :: L.Account } +newtype PriceConverteds = + PriceConverteds { unPriceConverteds :: [PriceConverted] } + convertOne :: L.PriceDb -> (L.Commodity, L.DateTime) @@ -92,27 +101,33 @@ buildDb = foldl f L.emptyDb where f db pb = L.addPrice db pb -converter :: - O.Options - -> [L.PricePoint] - -> [L.Box Ly.LibertyMeta] - -> Ex.Exceptional X.Text [PriceConverted] -converter os pbs bs = case O.convert os of - Nothing -> - let f b = PriceConverted en ac where +-- | Makes PriceConverteds where there is no target commodity. +nullConvert :: [L.Box Ly.LibertyMeta] -> PriceConverteds +nullConvert = + let f b = PriceConverted en ac + where p = L.boxPostFam b en = Q.entry p ac = Q.account p - in return . map f $ bs - Just pair -> + in PriceConverteds . map f + +-- | Makes PriceConverteds where commodities will have to be changed +-- to a target commodity. This will fail if necessary price data is +-- lacking. +converter :: + (L.Commodity, L.DateTime) + -> [L.PricePoint] + -> [L.Box Ly.LibertyMeta] + -> Ex.Exceptional X.Text PriceConverteds +converter conv pbs bs = let f b = let p = L.boxPostFam b en = Q.entry p ac = Q.account p in do - en' <- convertOne db pair en + en' <- convertOne db conv en return (PriceConverted en' ac) db = buildDb pbs - in mapM f bs + in fmap PriceConverteds $ mapM f bs -- Step 2. This puts all the PriceConverteds into a flat map, where @@ -120,9 +135,9 @@ -- the user desired, zero balances are eliminated from the flat map. newtype FlatMap = FlatMap { _unFlatMap :: M.Map L.Account Bal.Balance } -toFlatMap :: O.Options -> [PriceConverted] -> FlatMap -toFlatMap o = FlatMap . foldr f M.empty where - remove = not . CO.unShowZeroBalances . O.showZeroBalances $ o +toFlatMap :: TreeOpts -> PriceConverteds -> FlatMap +toFlatMap o = FlatMap . foldr f M.empty . unPriceConverteds where + remove = not . CO.unShowZeroBalances . showZeroBalances $ o f pc m = let a = pcAccount pc bal = Bal.entryToBalance . pcEntry $ pc @@ -236,7 +251,7 @@ -- | Returns a triple (x, y, z), where x is the DrCr chunk, y is the -- commodity chunk, and z is the qty chunk. bottomLineBalChunks :: - O.Options + TreeOpts -> IsEven -> (L.Commodity, Bal.BottomLine) -> (Chunk.Chunk, Chunk.Chunk, Chunk.Chunk) @@ -250,7 +265,7 @@ getTs = if isEven then C.evenZero else C.oddZero dcT = X.pack "--" qtyT = dcT - in (getTs . O.drCrColors $ os, dcT, qtyT) + in (getTs . drCrColors $ os, dcT, qtyT) Bal.NonZero clm -> let (getTs, dcT) = case Bal.drCr clm of L.Debit -> @@ -259,29 +274,29 @@ L.Credit -> (if isEven then C.evenCredit else C.oddCredit, X.pack "Cr") - qTxt = (O.balanceFormat os) bl - in (getTs . O.drCrColors $ os, dcT, qTxt) + qTxt = (balanceFormat os) bl + in (getTs . drCrColors $ os, dcT, qTxt) fillTextSpec :: - O.Options + TreeOpts -> IsEven -> Chunk.TextSpec fillTextSpec os isEven = let getTs = if isEven then C.evenColors else C.oddColors - in getTs . O.baseColors $ os + in getTs . baseColors $ os bottomLineCells :: - O.Options + TreeOpts -> IsEven -> SummedBal -> (PreSpec, PreSpec, PreSpec) bottomLineCells os isEven mayBal = let fill = fillTextSpec os isEven tsZero = if isEven - then C.evenZero . O.drCrColors $ os - else C.oddZero . O.drCrColors $ os + then C.evenZero . drCrColors $ os + else C.oddZero . drCrColors $ os zeroSpec = PreSpec R.LeftJustify tsZero [Chunk.chunk tsZero (X.pack "--")] @@ -298,7 +313,7 @@ padding = 2 accountPreSpec :: - O.Options + TreeOpts -> IsEven -> Int -> L.SubAccountName @@ -306,15 +321,15 @@ accountPreSpec os isEven lvl acct = PreSpec j ts [bit] where j = R.LeftJustify ts = if isEven - then C.evenColors . O.baseColors $ os - else C.oddColors . O.baseColors $ os + then C.evenColors . baseColors $ os + else C.oddColors . baseColors $ os bit = Chunk.chunk ts txt where txt = pad `X.append` (L.text acct) pad = X.replicate (padding * lvl) (X.singleton ' ') makePreSpec :: - O.Options + TreeOpts -> [(L.SubAccountName, (SummedBal, Bool))] -> L.SubAccountName -> (SummedBal, Bool) @@ -325,7 +340,7 @@ (dc, com, qt) = bottomLineCells os isEven mayBal traverser :: - O.Options + TreeOpts -> [(L.SubAccountName, (SummedBal, Bool))] -> L.SubAccountName -> (SummedBal, Bool) @@ -335,7 +350,7 @@ return (Just $ makePreSpec os hist a mayBal) makePreSpecMap :: - O.Options + TreeOpts -> (SummedWithIsEven, TotalBal) -> (PreSpecMap, TotalBal) makePreSpecMap os (sb, tb) = (cim, tb) where @@ -343,7 +358,7 @@ -- Step 7 makeTotalCells :: - O.Options + TreeOpts -> SummedBal -> Columns PreSpec makeTotalCells os mayBal = Columns act dc com qt where @@ -351,7 +366,7 @@ tot = L.SubAccountName $ L.TextNonEmpty 'T' (X.pack "otal") (dc, com, qt) = bottomLineCells os True mayBal -makeColumnList :: O.Options -> (PreSpecMap, TotalBal) -> [Columns PreSpec] +makeColumnList :: TreeOpts -> (PreSpecMap, TotalBal) -> [Columns PreSpec] makeColumnList os (cim, tb) = totCols : restCols where totCols = makeTotalCells os tb restCols = Fdbl.toList cim @@ -398,14 +413,14 @@ widthSpacerCommodity = 1 colsToBits :: - O.Options + TreeOpts -> IsEven -> Columns R.ColumnSpec -> [Chunk.Chunk] colsToBits os isEven (Columns a dc c q) = let fillSpec = if isEven - then C.evenColors . O.baseColors $ os - else C.oddColors . O.baseColors $ os + then C.evenColors . baseColors $ os + else C.oddColors . baseColors $ os spacer w = R.ColumnSpec j (Chunk.Width w) fillSpec [] j = R.LeftJustify cs = a @@ -419,7 +434,7 @@ in R.row cs colsListToBits :: - O.Options + TreeOpts -> [Columns R.ColumnSpec] -> [[Chunk.Chunk]] colsListToBits os = zipWith f bools where @@ -427,17 +442,22 @@ bools = iterate not True +-- Options +data TreeOpts = TreeOpts { + drCrColors :: C.DrCrColors + , baseColors :: C.BaseColors + , balanceFormat :: L.BottomLine -> X.Text + , showZeroBalances :: CO.ShowZeroBalances + } + -- Tie it all together report :: - O.Options - -> [L.Box Ly.LibertyMeta] - -> [L.PricePoint] - -> Ex.Exceptional X.Text [[Chunk.Chunk]] -report os ps rs = do - pcs <- converter os rs ps - return - . colsListToBits os + TreeOpts + -> PriceConverteds + -> [[Chunk.Chunk]] +report os = + colsListToBits os . resizeColumnsInList . makeColumnList os . makePreSpecMap os @@ -445,4 +465,4 @@ . sumBalances . rawBalances . toFlatMap os - $ pcs + diff --git a/Penny/Cabin/Posts.hs b/Penny/Cabin/Posts.hs --- a/Penny/Cabin/Posts.hs +++ b/Penny/Cabin/Posts.hs @@ -34,113 +34,363 @@ -- configurable without editing the source code (sorry). module Penny.Cabin.Posts ( - -- * Defaults - defaultPostsReport - - -- * Custom report - , customPostsReport - - -- * Options - , O.T(..) - , O.ReportWidth(..) - , O.ymd, O.qtyAsIs, O.balanceAsIs, O.defaultWidth - , O.columnsVarToWidth, O.defaultOptions, O.widthFromRuntime - , O.defaultFields + postsReport + , parseReport + , makeReport + , defaultOptions + , ZincOpts(..) + , ymd + , qtyAsIs + , balanceAsIs + , defaultWidth + , columnsVarToWidth + , widthFromRuntime + , defaultFields + , defaultSpacerWidth ) where -import Control.Applicative ((<$>)) import qualified Control.Monad.Exception.Synchronous as Ex import qualified Data.Text as X import qualified Data.Text.Lazy as XL -import qualified Penny.Cabin.Chunk as Chk +import qualified Penny.Cabin.Chunk as CC +import qualified Penny.Cabin.Colors as PC +import qualified Penny.Cabin.Colors.DarkBackground as Dark import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Posts.Options as O +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Posts.Allocated as A +import qualified Penny.Cabin.Posts.Allocate as Alc +import qualified Penny.Cabin.Posts.Chunk as C +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Help as H import qualified Penny.Cabin.Posts.Meta as M -import Penny.Cabin.Posts.Chunk (makeChunk) -import Penny.Cabin.Posts.Parser (parseOptions) -import Penny.Cabin.Posts.Help (help) -import qualified Penny.Copper as C +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.Copper as Cop import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Balance as Bal +import qualified Penny.Lincoln.Queries as Q import qualified Penny.Liberty as Ly -import qualified Penny.Shield as S +import qualified Penny.Shield as Sh + +import Data.Time as Time import System.Console.MultiArg.Prim (Parser) +import System.Locale (defaultTimeLocale) import Text.Matchers.Text (CaseSensitive) --- | When applied to a DefaultTimeZone and a RadGroup, returns a --- report with the default options. -defaultPostsReport :: - C.DefaultTimeZone - -> C.RadGroup - -> I.Report -defaultPostsReport dtz rg = makeReport f where - f = parseReportOpts (\rt -> O.defaultOptions dtz rg rt) +-- | All information needed to make a Posts report. This function +-- never fails. +postsReport :: + CC.Colors + -- ^ How many colors to show. + -> CO.ShowZeroBalances + -> (L.Box Ly.LibertyMeta -> Bool) + -- ^ Removes posts from the report if applying this function to the + -- post returns False. Posts removed still affect the running + -- balance. + + -> [Ly.PostFilterFn] + -- ^ Applies these post-filters to the list of posts that results + -- from applying the predicate above. Might remove more + -- postings. Postings removed still affect the running balance. + + -> C.ChunkOpts + -> [L.Box Ly.LibertyMeta] + -> XL.Text --- | Generate a custom Posts report. -customPostsReport :: - (S.Runtime -> O.T) - -- ^ Function that, when applied to a Runtime, returns the default - -- options for the posts report. The options will be overridden by - -- any options on the command line. +postsReport col szb pdct pff co = + CC.chunksToText col + . C.makeChunk co + . M.toBoxList szb pdct pff - -> I.Report -customPostsReport = makeReport . parseReportOpts --- | When passed a ParseReportOpts, makes a Report. +parseReport :: + (Sh.Runtime -> ZincOpts) + -> Parser I.ReportFunc +parseReport frt = do + getState <- P.parseOptions + let rf rt cs fty ps _ = do + let zo = frt rt + maySt' = getState rt dtz rg st + where + dtz = defaultTimeZone zo + rg = radGroup zo + st = newParseState cs fty zo + st' <- Ex.mapException showParserError maySt' + pdct <- getPredicate . P.tokens $ st' + return $ postsReport (P.colorPref st') + (P.showZeroBalances st') pdct + (P.postFilter st') (chunkOpts st' zo) ps + return rf + + makeReport :: - Parser I.ReportFunc + (Sh.Runtime -> ZincOpts) -> I.Report -makeReport f = - I.Report { I.help = help - , I.name = "posts" - , I.parseReport = f } +makeReport frt = I.Report { + I.help = H.help + , I.name = "postings" + , I.parseReport = parseReport frt } -type Factory = CaseSensitive -> X.Text - -> Ex.Exceptional X.Text (X.Text -> Bool) -parseReportOpts :: - (S.Runtime -> O.T) - -> Parser (S.Runtime - -> CaseSensitive - -> Factory - -> [L.Box Ly.LibertyMeta] - -> a - -> Ex.Exceptional X.Text XL.Text) -parseReportOpts frt = do - getOpts <- parseOptions - let f rt cs fty bs _ = do - let optsDefault = frt rt - optsInit = optsDefault { O.sensitive = cs - , O.factory = fty } - optsParsed <- case getOpts rt optsInit of - Ex.Exception e -> Ex.throw . X.pack . show $ e - Ex.Success g -> return g - makeReportTxt optsParsed bs - return f - +defaultOptions :: + Cop.DefaultTimeZone + -> Cop.RadGroup + -> Sh.Runtime + -> ZincOpts +defaultOptions dtz rg rt = ZincOpts { + defaultTimeZone = dtz + , radGroup = rg + , fields = defaultFields + , colorPref = CO.maxCapableColors rt + , drCrColors = Dark.drCrColors + , baseColors = Dark.baseColors + , width = widthFromRuntime rt + , showZeroBalances = CO.ShowZeroBalances False + , dateFormat = ymd + , qtyFormat = qtyAsIs + , balanceFormat = balanceAsIs + , subAccountLength = A.SubAccountLength 2 + , payeeAllocation = Alc.allocation 60 + , accountAllocation = Alc.allocation 40 + , spacers = defaultSpacerWidth } --- | Using the options parsed from the command line, print out the --- report. -makeReportTxt :: - O.T - -> [L.Box Ly.LibertyMeta] - -> Ex.Exceptional X.Text XL.Text -makeReportTxt op bs = fmap mkText postMetaBoxes - where - e = X.pack "posts report: filter expression parse failure" - postMetaBoxes = Ex.fromMaybe e (filterAndAssignMeta op bs) - mkText = Chk.chunksToText (O.colorPref op) . makeChunk op - --- | Takes a list of Box with LibertyMeta and options as processed --- from the command line. Filters the list of Box and processes the --- post filter, then assigns the post metadata. Fails if the --- expression fails to produce a result. -filterAndAssignMeta :: - O.T - -> [L.Box Ly.LibertyMeta] - -> Maybe [L.Box M.PostMeta] -filterAndAssignMeta op bs = - M.addMetadata (O.showZeroBalances op) - <$> M.filterBoxes (O.tokens op) (O.postFilter op) bs +showParserError :: P.Error -> X.Text +showParserError = X.pack . show +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) + +-- | All the information to configure the postings report if the +-- options will be parsed in from the command line. +data ZincOpts = ZincOpts { + defaultTimeZone :: Cop.DefaultTimeZone + -- ^ The postings report takes options to determine which posts will + -- be visible. This determines the time zone to use when parsing + -- these options. Does not affect how the resulting report is + -- formatted. For that, see the dateFormat field. + + , radGroup :: Cop.RadGroup + -- ^ The postings report takes options to determine which posts + -- will be visible. This determines the radix point and grouping + -- character to use when parsing these options. Does not affect + -- how the resulting report is formatted. For that, see the + -- qtyFormat field. + + , fields :: F.Fields Bool + -- ^ Default fields to show in the report. + + , colorPref :: CC.Colors + -- ^ How many colors you want to see, or do it + -- automatically. + + , drCrColors :: PC.DrCrColors + -- ^ Colors to use when displaying debits, credits, and + -- when displaying balance totals + + , baseColors :: PC.BaseColors + -- ^ Colors to use when displaying everything else + + , width :: T.ReportWidth + -- ^ Gives the default report width. This can be + -- overridden on the command line. You can use the + -- information from the Runtime to make this as wide as + -- the current terminal. + + , showZeroBalances :: CO.ShowZeroBalances + -- ^ Are commodities that have no balance shown in the Total fields + -- of the report? + + , dateFormat :: Box -> X.Text + -- ^ How to display dates. This function is applied to the + -- a PostingInfo so it has lots of information, but it + -- should return a date for use in the Date field. + + , qtyFormat :: Box -> X.Text + -- ^ How to display the quantity of the posting. This + -- function is applied to a Box so it has lots of + -- information, but it should return a formatted string of + -- the quantity. Allows you to format digit grouping, + -- radix points, perform rounding, etc. + + , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + -- ^ How to display balance totals. Similar to + -- balanceFormat. + + , subAccountLength :: A.SubAccountLength + -- ^ When shortening the names of sub accounts to make + -- them fit, they will be this long. + + , payeeAllocation :: Alc.Allocation + -- ^ This and accountAllocation determine how much space + -- payees and accounts receive. They divide up the + -- remaining space after everything else is displayed. For + -- instance if payeeAllocation is 60 and accountAllocation + -- is 40, the payee takes about 60 percent of the + -- remaining space and the account takes about 40 percent. + + , accountAllocation :: Alc.Allocation + -- ^ See payeeAllocation above + + , spacers :: S.Spacers Int + -- ^ Default width for spacer fields. If any of these Ints are + -- less than or equal to zero, there will be no spacer. There is + -- never a spacer for fields that do not appear in the report. + + } + +chunkOpts :: + P.State + -> ZincOpts + -> C.ChunkOpts +chunkOpts s z = C.ChunkOpts { + C.baseColors = P.baseColors s + , C.drCrColors = P.drCrColors s + , 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.colorPref = colorPref o + , P.drCrColors = drCrColors o + , P.baseColors = baseColors o + , P.width = width o + , P.showZeroBalances = showZeroBalances o + } + +-- | Shows the date of a posting in YYYY-MM-DD format. +ymd :: Box -> X.Text +ymd p = X.pack (Time.formatTime defaultTimeLocale fmt d) where + d = Time.localDay + . L.localTime + . Q.dateTime + . L.boxPostFam + $ p + fmt = "%Y-%m-%d" + +-- | Shows the quantity of a posting. Does no rounding or +-- prettification; simply uses show on the underlying Decimal. +qtyAsIs :: Box -> X.Text +qtyAsIs p = X.pack . show . L.unQty . Q.qty . L.boxPostFam $ p + +-- | Shows the quantity of a balance. If there is no quantity, shows +-- two dashes. +balanceAsIs :: a -> L.BottomLine -> X.Text +balanceAsIs _ n = case n of + L.Zero -> X.pack "--" + L.NonZero c -> X.pack . show . L.unQty . Bal.qty $ c + +-- | The default width for the report. +defaultWidth :: T.ReportWidth +defaultWidth = T.ReportWidth 80 + +-- | Applied to the value of the COLUMNS environment variable, returns +-- an appropriate ReportWidth. +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 + +-- | Given the Runtime, use the defaultWidth given above to calculate +-- the report's width if COLUMNS does not yield a value. Otherwise, +-- use what is in COLUMNS. +widthFromRuntime :: Sh.Runtime -> T.ReportWidth +widthFromRuntime rt = case Sh.screenWidth rt of + Nothing -> defaultWidth + Just w -> T.ReportWidth . Sh.unScreenWidth $ w + +-- | Default fields to show in the Postings report. +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 } + +-- | Default width of spacers; most are one character wide, but the +-- spacer after payee is 4 characters wide. +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 } diff --git a/Penny/Cabin/Posts/Allocated.hs b/Penny/Cabin/Posts/Allocated.hs --- a/Penny/Cabin/Posts/Allocated.hs +++ b/Penny/Cabin/Posts/Allocated.hs @@ -29,7 +29,12 @@ -- arrangements are made if either field gets an allocation of 0. -- -- 5. Fill cell contents. Return filled cells. -module Penny.Cabin.Posts.Allocated (payeeAndAcct, Fields(..)) where +module Penny.Cabin.Posts.Allocated ( + payeeAndAcct + , AllocatedOpts(..) + , Fields(..) + , SubAccountLength(..) + ) where import Control.Applicative(Applicative((<*>), pure), (<$>)) import Data.Maybe (catMaybes, isJust) @@ -42,25 +47,37 @@ import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.Posts.Allocate as A import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Posts.Fields as F import qualified Penny.Cabin.Posts.Growers as G import qualified Penny.Cabin.Posts.Meta as M -import qualified Penny.Cabin.Posts.Options as Options -import qualified Penny.Cabin.Posts.Options as O +import Penny.Cabin.Posts.Meta (Box) import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Posts.Spacers as Spacers +import qualified Penny.Cabin.Posts.Types as Ty import qualified Penny.Cabin.TextFormat as TF import qualified Penny.Lincoln as L import qualified Penny.Lincoln.Queries as Q import qualified Penny.Lincoln.HasText as HT -type Box = L.Box M.PostMeta - data Fields a = Fields { payee :: a , account :: a } deriving (Eq, Show) +newtype SubAccountLength = + SubAccountLength { unSubAccountLength :: Int } + deriving Show + +-- | All the information needed for allocated cells. +data AllocatedOpts = AllocatedOpts { + fields :: Fields Bool + , subAccountLength :: SubAccountLength + , baseColors :: PC.BaseColors + , payeeAllocation :: A.Allocation + , accountAllocation :: A.Allocation + , spacers :: S.Spacers Int + , growerWidths :: G.Fields (Maybe Int) + , reportWidth :: Ty.ReportWidth + } + -- | Creates Payee and Account cells. The user must have requested the -- cells. In addition, no cells are created if there is not enough -- space for them in the report. Returns a Fields; each element of the @@ -69,31 +86,36 @@ -- where cs is a list of all the cells, and i is the width of all the -- cells. payeeAndAcct :: - G.Fields (Maybe Int) - -> Options.T + AllocatedOpts -> [Box] -> Fields (Maybe ([R.ColumnSpec], Int)) -payeeAndAcct fs os = allocateCells os ws where - ws = fieldWidth os ss fs rw - ss = O.spacers os - rw = O.width os +payeeAndAcct as = allocateCells sl bc ws + where + sl = subAccountLength as + bc = baseColors as + ws = fieldWidth (fields as) (payeeAllocation as) + (accountAllocation as) (spacers as) + (growerWidths as) (reportWidth as) -- | Allocates cells. Returns a pair, with the first element being the -- list of allocated cells, and the second indicating the width of the -- cells, which will be greater than zero. allocateCells :: - Options.T - -> Fields Int + SubAccountLength + -> PC.BaseColors + -> Fields UnShrunkWidth -> [Box] -> Fields (Maybe ([R.ColumnSpec], Int)) -allocateCells os fs is = let - cellMakers = Fields allocPayee allocAcct - mkCells width maker = - if width > 0 - then Just (map (maker width os) is) - else Nothing - unShrunkCells = mkCells <$> fs <*> cellMakers +allocateCells sl bc fs bs = + let mkPayees i b = allocPayee i bc b + mkAccts i b = allocAcct i sl bc b + cellMakers = Fields mkPayees mkAccts + mkCells (UnShrunkWidth width) maker = + if width > 0 + then Just (map (maker width) bs) + else Nothing + unShrunkCells = mkCells <$> fs <*> cellMakers in fmap (fmap removeExtraSpace) unShrunkCells @@ -109,32 +131,32 @@ trimmed = map f cs where f c = c { R.width = C.Width len } +-- | The width of an on-screen field, after accounting for the width +-- of the entire report and the allocations but before shrinking. +newtype UnShrunkWidth = UnShrunkWidth Int + deriving Show + -- | Gets the width of the two allocated fields. fieldWidth :: - Options.T - -> Spacers.T Int + Fields Bool + -> A.Allocation -- ^ Payee allocation + -> A.Allocation -- ^ Accout allocation + -> S.Spacers Int -> G.Fields (Maybe Int) - -> O.ReportWidth - -> Fields Int -fieldWidth os ss fs (O.ReportWidth rw) = let - flds = optionsToFields os - grownWidth = sumGrowersAndSpacers fs ss - widthForCells = rw - grownWidth - allocSpacerWidth - payeeSpacerWidth = if payee flds then abs (S.payee ss) else 0 - acctSpacerWidth = if account flds then abs (S.account ss) else 0 - allocSpacerWidth = payeeSpacerWidth + acctSpacerWidth - allocs = (\bool alloc -> if bool then alloc else A.allocation 0) - <$> flds - <*> Fields (O.payeeAllocation os) (O.accountAllocation os) + -> Ty.ReportWidth + -> Fields UnShrunkWidth +fieldWidth flds pa aa ss fs (Ty.ReportWidth rw) = + let grownWidth = sumGrowersAndSpacers fs ss + widthForCells = rw - grownWidth - allocSpacerWidth + payeeSpacerWidth = if payee flds then abs (S.payee ss) else 0 + acctSpacerWidth = if account flds then abs (S.account ss) else 0 + allocSpacerWidth = payeeSpacerWidth + acctSpacerWidth + allocs = (\bool alloc -> if bool then alloc else A.allocation 0) + <$> flds + <*> Fields pa aa in if widthForCells < 1 - then pure 0 - else A.allocate allocs widthForCells - - -optionsToFields :: Options.T -> Fields Bool -optionsToFields os = let f = O.fields os in Fields { - payee = F.payee f - , account = F.account f } + then pure (UnShrunkWidth 0) + else fmap UnShrunkWidth $ A.allocate allocs widthForCells -- | Sums spacers for growing cells. This function is intended for use @@ -147,7 +169,7 @@ -- Spacers. sumSpacers :: G.Fields (Maybe a) - -> Spacers.T Int + -> S.Spacers Int -> Int sumSpacers fs = sum @@ -201,7 +223,7 @@ -- the GFields, which indicates each particular field. pairedWithSpacers :: G.Fields a - -> Spacers.T b + -> S.Spacers b -> G.Fields (a, Maybe b, G.EFields) pairedWithSpacers f s = (\(a, b) c -> (a, b, c)) @@ -212,56 +234,67 @@ -- spacers; makes the adjustments described in sumSpacers. sumGrowersAndSpacers :: G.Fields (Maybe Int) - -> Spacers.T Int + -> S.Spacers Int -> Int -sumGrowersAndSpacers fs ss = spacers + flds where - spacers = sumSpacers fs ss +sumGrowersAndSpacers fs ss = spcrs + flds where + spcrs = sumSpacers fs ss flds = Fdbl.foldr f 0 fs where f maybeI acc = case maybeI of Nothing -> acc Just i -> acc + i -allocPayee :: Int -> Options.T -> Box -> R.ColumnSpec -allocPayee w os i = let - pb = L.boxPostFam i - ts = PC.colors (M.visibleNum . L.boxMeta $ i) (O.baseColors os) - c = R.ColumnSpec j (C.Width w) ts sq - j = R.LeftJustify - sq = case Q.payee pb of - Nothing -> [] - Just pye -> let - wrapped = - Fdbl.toList - . TF.unLines - . TF.wordWrap w - . TF.txtWords - . HT.text - $ pye - toBit (TF.Words seqTxts) = - C.chunk ts - . X.unwords - . Fdbl.toList - $ seqTxts - in fmap toBit wrapped +allocPayee :: + Int + -- ^ Width that is permitted for this column + -> PC.BaseColors + -> Box + -> R.ColumnSpec +allocPayee w bc i = + let pb = L.boxPostFam i + ts = PC.colors (M.visibleNum . L.boxMeta $ i) bc + c = R.ColumnSpec j (C.Width w) ts sq + j = R.LeftJustify + sq = case Q.payee pb of + Nothing -> [] + Just pye -> + let wrapped = + Fdbl.toList + . TF.unLines + . TF.wordWrap w + . TF.txtWords + . HT.text + $ pye + toBit (TF.Words seqTxts) = + C.chunk ts + . X.unwords + . Fdbl.toList + $ seqTxts + in fmap toBit wrapped in c -allocAcct :: Int -> Options.T -> Box -> R.ColumnSpec -allocAcct aw os i = let - pb = L.boxPostFam i - ts = PC.colors (M.visibleNum . L.boxMeta $ i) (O.baseColors os) in - R.ColumnSpec R.LeftJustify (C.Width aw) ts $ let - target = TF.Target aw - shortest = TF.Shortest . O.subAccountLength $ os - a = Q.account pb - ws = TF.Words . Seq.fromList . HT.textList $ a - (TF.Words shortened) = TF.shorten shortest target ws - in [C.chunk ts - . X.concat - . intersperse (X.singleton ':') - . Fdbl.toList - $ shortened] +allocAcct :: + Int + -- ^ Width that is permitted for this column + -> SubAccountLength + -> PC.BaseColors + -> Box + -> R.ColumnSpec +allocAcct aw sl bc i = + let pb = L.boxPostFam i + ts = PC.colors (M.visibleNum . L.boxMeta $ i) bc + in R.ColumnSpec R.LeftJustify (C.Width aw) ts $ + let target = TF.Target aw + shortest = TF.Shortest . unSubAccountLength $ sl + a = Q.account pb + ws = TF.Words . Seq.fromList . HT.textList $ a + (TF.Words shortened) = TF.shorten shortest target ws + in [C.chunk ts + . X.concat + . intersperse (X.singleton ':') + . Fdbl.toList + $ shortened] instance Functor Fields where fmap f i = Fields { diff --git a/Penny/Cabin/Posts/BottomRows.hs b/Penny/Cabin/Posts/BottomRows.hs --- a/Penny/Cabin/Posts/BottomRows.hs +++ b/Penny/Cabin/Posts/BottomRows.hs @@ -17,6 +17,7 @@ -- combined. Each bottom row will have one cell. module Penny.Cabin.Posts.BottomRows ( + BottomOpts(..), bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers, topRowCells) where @@ -35,31 +36,34 @@ import qualified Penny.Cabin.TextFormat as TF import qualified Penny.Cabin.Posts.Allocated as A import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Posts.Fields as Fields import qualified Penny.Cabin.Posts.Fields as F import qualified Penny.Cabin.Posts.Growers as G import qualified Penny.Cabin.Posts.Meta as M -import qualified Penny.Cabin.Posts.Options as Options -import qualified Penny.Cabin.Posts.Options as O -import qualified Penny.Cabin.Posts.Spacers as Spacers +import Penny.Cabin.Posts.Meta (Box) import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Posts.Types as Ty import qualified Penny.Lincoln as L import qualified Penny.Lincoln.HasText as HT import qualified Penny.Lincoln.Queries as Q -type Box = L.Box M.PostMeta +data BottomOpts = BottomOpts { + growingWidths :: G.Fields (Maybe Int) + , allocatedWidths :: A.Fields (Maybe Int) + , fields :: F.Fields Bool + , baseColors :: PC.BaseColors + , reportWidth :: Ty.ReportWidth + , spacers :: S.Spacers Int + } bottomRows :: - G.Fields (Maybe Int) - -> A.Fields (Maybe Int) - -> Options.T + BottomOpts -> [Box] -> Fields (Maybe [[C.Chunk]]) -bottomRows gf af os is = makeRows is pcs where - pcs = infoProcessors topSpecs rw wanted - wanted = requestedMakers os - topSpecs = topCellSpecs gf af (O.spacers os) - rw = O.width os +bottomRows os bs = makeRows bs pcs where + pcs = infoProcessors topSpecs (reportWidth os) wanted + wanted = requestedMakers (fields os) (baseColors os) + topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os) + (spacers os) data Fields a = Fields { @@ -86,7 +90,7 @@ , filename = (filename ff) (filename fa) } -bottomRowsFields :: Fields.T a -> Fields a +bottomRowsFields :: F.Fields a -> Fields a bottomRowsFields f = Fields { tags = F.tags f , memo = F.memo f @@ -137,16 +141,16 @@ widthOfReport :: - O.ReportWidth + Ty.ReportWidth -> (Box -> Int -> (C.TextSpec, R.ColumnSpec)) -> Box -> [C.Chunk] -widthOfReport (O.ReportWidth rw) fn info = +widthOfReport (Ty.ReportWidth rw) fn info = makeSpecificWidth rw fn info chooseProcessor :: [TopCellSpec] - -> O.ReportWidth + -> Ty.ReportWidth -> (Box -> Int -> (C.TextSpec, R.ColumnSpec)) -> Box -> [C.Chunk] @@ -159,7 +163,7 @@ infoProcessors :: [TopCellSpec] - -> O.ReportWidth + -> Ty.ReportWidth -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec))) -> Fields (Maybe (Box -> [C.Chunk])) infoProcessors specs rw flds = let @@ -218,7 +222,7 @@ topCellSpecs :: G.Fields (Maybe Int) -> A.Fields (Maybe Int) - -> Spacers.T Int + -> S.Spacers Int -> [TopCellSpec] topCellSpecs gFlds aFlds spcs = let allFlds = topRowCells gFlds aFlds @@ -236,7 +240,7 @@ -- totalQty has no spacer. mergeWithSpacers :: TopRowCells a - -> Spacers.T b + -> S.Spacers b -> TopRowCells (a, Maybe b) mergeWithSpacers t s = TopRowCells { globalTransaction = (globalTransaction t, Just (S.globalTransaction s)) @@ -275,7 +279,7 @@ (_, c) = f i w -type Maker = Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec) +type Maker = PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) makers :: Fields Maker makers = Fields tagsCell memoCell filenameCell @@ -284,18 +288,19 @@ -- returns a Fields (Maybe Maker) with a Maker in each respective -- field that the user wants to see. requestedMakers :: - Options.T + F.Fields Bool + -> PC.BaseColors -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec))) -requestedMakers os = let - flds = bottomRowsFields (O.fields os) - filler b mkr = if b then Just $ mkr os else Nothing +requestedMakers allFlds bc = + let flds = bottomRowsFields allFlds + filler b mkr = if b then Just $ mkr bc else Nothing in filler <$> flds <*> makers -tagsCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -tagsCell os info w = (ts, cell) where +tagsCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) +tagsCell bc info w = (ts, cell) where vn = M.visibleNum . L.boxMeta $ info cell = R.ColumnSpec R.LeftJustify (C.Width w) ts cs - ts = PC.colors vn (O.baseColors os) + ts = PC.colors vn bc cs = Fdbl.toList . fmap toBit @@ -328,12 +333,12 @@ toBit (TF.Words ws) = C.chunk ts (X.unwords . Fdbl.toList $ ws) -memoCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -memoCell os info width = (ts, cell) where +memoCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) +memoCell bc info width = (ts, cell) where w = C.Width width vn = M.visibleNum . L.boxMeta $ info cell = R.ColumnSpec R.LeftJustify w ts cs - ts = PC.colors vn (O.baseColors os) + ts = PC.colors vn bc pm = Q.postingMemo . L.boxPostFam $ info tm = Q.transactionMemo . L.boxPostFam $ info nullMemo (L.Memo m) = null m @@ -344,8 +349,8 @@ (False, False) -> memoBits ts pm w `mappend` memoBits ts tm w -filenameCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -filenameCell os info width = (ts, cell) where +filenameCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) +filenameCell bc info width = (ts, cell) where w = C.Width width vn = M.visibleNum . L.boxMeta $ info cell = R.ColumnSpec R.LeftJustify w ts cs @@ -354,7 +359,7 @@ cs = case Q.filename . L.boxPostFam $ info of Nothing -> [] Just fn -> [toBit . L.unFilename $ fn] - ts = PC.colors vn (O.baseColors os) + ts = PC.colors vn bc diff --git a/Penny/Cabin/Posts/Chunk.hs b/Penny/Cabin/Posts/Chunk.hs --- a/Penny/Cabin/Posts/Chunk.hs +++ b/Penny/Cabin/Posts/Chunk.hs @@ -1,33 +1,90 @@ -module Penny.Cabin.Posts.Chunk (makeChunk) where +module Penny.Cabin.Posts.Chunk (ChunkOpts(..), makeChunk) where import qualified Data.Foldable as Fdbl import Data.List (transpose) import Data.Maybe (isNothing, catMaybes) +import qualified Penny.Cabin.Posts.Fields as F import qualified Penny.Cabin.Posts.Growers as G import qualified Penny.Cabin.Posts.Allocated as A +import qualified Penny.Cabin.Posts.Allocate as Alc import qualified Penny.Cabin.Posts.BottomRows as B -import qualified Penny.Cabin.Posts.Options as Options +import qualified Penny.Cabin.Posts.Spacers as S import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.Chunk as C import qualified Penny.Cabin.Colors as PC +import Penny.Cabin.Posts.Meta (Box) import qualified Penny.Lincoln as L -import qualified Penny.Cabin.Posts.Meta as M +import qualified Data.Text as X +import qualified Penny.Cabin.Posts.Types as Ty -type Box = L.Box M.PostMeta +data ChunkOpts = ChunkOpts { + baseColors :: PC.BaseColors + , drCrColors :: PC.DrCrColors + , dateFormat :: Box -> X.Text + , qtyFormat :: Box -> X.Text + , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + , fields :: F.Fields Bool + , subAccountLength :: A.SubAccountLength + , payeeAllocation :: Alc.Allocation + , accountAllocation :: Alc.Allocation + , spacers :: S.Spacers Int + , reportWidth :: Ty.ReportWidth + } -makeChunk :: Options.T -> [Box] -> [C.Chunk] -makeChunk os is = let - fmapSnd flds = fmap (fmap snd) flds - fmapFst flds = fmap (fmap fst) flds - gFldW = fmapSnd gFlds - aFldW = fmapSnd aFlds - gFlds = G.growCells os is - aFlds = A.payeeAndAcct gFldW os is - bFlds = B.bottomRows gFldW aFldW os is - topCells = B.topRowCells (fmapFst gFlds) (fmapFst aFlds) - withSpacers = B.mergeWithSpacers topCells (Options.spacers os) - topRows = makeTopRows (Options.baseColors os) withSpacers - bottomRows = makeBottomRows bFlds +growOpts :: ChunkOpts -> G.GrowOpts +growOpts c = G.GrowOpts { + G.baseColors = baseColors c + , G.drCrColors = drCrColors c + , G.dateFormat = dateFormat c + , G.qtyFormat = qtyFormat c + , G.balanceFormat = balanceFormat c + , G.fields = fields c + } + +allocatedOpts :: ChunkOpts -> G.Fields (Maybe Int) -> A.AllocatedOpts +allocatedOpts c g = A.AllocatedOpts { + A.fields = let f = fields c + in A.Fields { A.payee = F.payee f + , A.account = F.account f } + , A.subAccountLength = subAccountLength c + , A.baseColors = baseColors c + , A.payeeAllocation = payeeAllocation c + , A.accountAllocation = accountAllocation c + , A.spacers = spacers c + , A.growerWidths = g + , A.reportWidth = reportWidth c + } + +bottomOpts :: + ChunkOpts + -> G.Fields (Maybe Int) + -> A.Fields (Maybe Int) + -> B.BottomOpts +bottomOpts c g a = B.BottomOpts { + B.growingWidths = g + , B.allocatedWidths = a + , B.fields = fields c + , B.baseColors = baseColors c + , B.reportWidth = reportWidth c + , B.spacers = spacers c + } + +makeChunk :: + ChunkOpts + -> [Box] + -> [C.Chunk] +makeChunk c bs = + let fmapSnd = fmap (fmap snd) + fmapFst = fmap (fmap fst) + gFldW = fmap (fmap snd) gFlds + aFldW = fmapSnd aFlds + gFlds = G.growCells (growOpts c) bs + aFlds = A.payeeAndAcct (allocatedOpts c gFldW) bs + bFlds = B.bottomRows (bottomOpts c gFldW aFldW) bs + topCells = B.topRowCells (fmapFst gFlds) (fmap (fmap fst) aFlds) + withSpacers = B.mergeWithSpacers topCells (spacers c) + topRows = makeTopRows (baseColors c) withSpacers + bottomRows = makeBottomRows bFlds in makeAllRows topRows bottomRows diff --git a/Penny/Cabin/Posts/Fields.hs b/Penny/Cabin/Posts/Fields.hs --- a/Penny/Cabin/Posts/Fields.hs +++ b/Penny/Cabin/Posts/Fields.hs @@ -4,7 +4,7 @@ import Control.Applicative(Applicative(pure, (<*>))) import qualified Data.Foldable as F -data T a = T { +data Fields a = Fields { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a @@ -37,8 +37,8 @@ , filename :: a } deriving (Show, Eq) -instance Functor T where - fmap f fa = T { +instance Functor Fields where + fmap f fa = Fields { globalTransaction = f (globalTransaction fa) , revGlobalTransaction = f (revGlobalTransaction fa) , globalPosting = f (globalPosting fa) @@ -69,8 +69,8 @@ , memo = f (memo fa) , filename = f (filename fa) } -instance Applicative T where - pure a = T { +instance Applicative Fields where + pure a = Fields { globalTransaction = a , revGlobalTransaction = a , globalPosting = a @@ -101,7 +101,7 @@ , memo = a , filename = a } - ff <*> fa = T { + ff <*> fa = Fields { globalTransaction = globalTransaction ff (globalTransaction fa) , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa) @@ -133,7 +133,7 @@ , memo = memo ff (memo fa) , filename = filename ff (filename fa) } -instance F.Foldable T where +instance F.Foldable Fields where foldr f z t = f (globalTransaction t) (f (revGlobalTransaction t) diff --git a/Penny/Cabin/Posts/Growers.hs b/Penny/Cabin/Posts/Growers.hs --- a/Penny/Cabin/Posts/Growers.hs +++ b/Penny/Cabin/Posts/Growers.hs @@ -2,6 +2,7 @@ -- widest cell in the column. No information is ever truncated from -- these cells (what use is a truncated dollar amount?) module Penny.Cabin.Posts.Growers ( + GrowOpts(..), growCells, Fields(..), grownWidth, eFields, EFields(..), pairWithSpacer) where @@ -13,20 +14,26 @@ import Data.Text (Text, pack, empty) import qualified Data.Text as X import qualified Penny.Cabin.Chunk as C -import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Posts.Options as O -import qualified Penny.Cabin.Posts.Options as Options +import qualified Penny.Cabin.Colors as CC 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.Spacers as S -import qualified Penny.Cabin.Posts.Spacers as Spacers import qualified Penny.Cabin.Row as R import qualified Penny.Liberty as Ly import qualified Penny.Lincoln as L import qualified Penny.Lincoln.Queries as Q -type Box = L.Box M.PostMeta +-- | All the options needed to grow the cells. +data GrowOpts = GrowOpts { + baseColors :: CC.BaseColors + , drCrColors :: CC.DrCrColors + , dateFormat :: Box -> X.Text + , qtyFormat :: Box -> X.Text + , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + , fields :: F.Fields Bool + } -- | Grows the cells that will be GrowToFit cells in the report. First -- this function fills in all visible cells with text, but leaves the @@ -39,19 +46,19 @@ -- the report but that ended up having no width are changed to -- Nothing. growCells :: - Options.T + GrowOpts -> [Box] -> Fields (Maybe ([R.ColumnSpec], Int)) growCells o infos = toPair <$> wanted <*> growers where toPair b gwr - | b = let - cs = map (gwr o) infos - w = Fdbl.foldl' f 0 cs where - f acc c = max acc (widestLine c) - cs' = map (sizer (R.Width w)) cs + | b = + let cs = map (gwr o) infos + w = Fdbl.foldl' f 0 cs where + f acc c = max acc (widestLine c) + cs' = map (sizer (R.Width w)) cs in if w > 0 then Just (cs', w) else Nothing | otherwise = Nothing - wanted = growingFields o + wanted = growingFields . fields $ o widestLine :: PreSpec -> Int widestLine (PreSpec _ _ bs) = @@ -70,49 +77,74 @@ -- | Makes a left justified cell that is only one line long. The width -- is unset. -oneLine :: Text -> Options.T -> Box -> PreSpec -oneLine t os b = - let bc = Options.baseColors os - ts = PC.colors (M.visibleNum . L.boxMeta $ b) bc +oneLine :: Text -> CC.BaseColors -> Box -> PreSpec +oneLine t bc b = + let ts = CC.colors (M.visibleNum . L.boxMeta $ b) bc j = R.LeftJustify bit = C.chunk ts t in PreSpec j ts [bit] -growers :: Fields (Options.T -> Box -> PreSpec) +-- | Converts a function that accepts a BaseColors to one that accepts +-- a GrowOpts. +bcToGrowOpts :: + (CC.BaseColors -> Box -> PreSpec) + -> GrowOpts -> Box -> PreSpec +bcToGrowOpts f g = f (baseColors g) + +-- | Converts a function that accepts a DrCrColors to one that accepts +-- a GrowOpts. +dcToGrowOpts :: + (CC.DrCrColors -> Box -> PreSpec) + -> GrowOpts -> Box -> PreSpec +dcToGrowOpts f g = f (drCrColors g) + + +-- | Gets a Fields with each field filled with the function that fills +-- the cells for that field. +growers :: Fields (GrowOpts -> Box -> PreSpec) growers = Fields { - globalTransaction = getGlobalTransaction - , revGlobalTransaction = getRevGlobalTransaction - , globalPosting = getGlobalPosting - , revGlobalPosting = getRevGlobalPosting - , fileTransaction = getFileTransaction - , revFileTransaction = getRevFileTransaction - , filePosting = getFilePosting - , revFilePosting = getRevFilePosting - , filtered = getFiltered - , revFiltered = getRevFiltered - , sorted = getSorted - , revSorted = getRevSorted - , visible = getVisible - , revVisible = getRevVisible - , lineNum = getLineNum - , date = getDate - , flag = getFlag - , number = getNumber - , postingDrCr = getPostingDrCr - , postingCmdty = getPostingCmdty - , postingQty = getPostingQty - , totalDrCr = getTotalDrCr - , totalCmdty = getTotalCmdty - , totalQty = getTotalQty } + globalTransaction = bcToGrowOpts getGlobalTransaction + , revGlobalTransaction = bcToGrowOpts getRevGlobalTransaction + , globalPosting = bcToGrowOpts getGlobalPosting + , revGlobalPosting = bcToGrowOpts getRevGlobalPosting + , fileTransaction = bcToGrowOpts getFileTransaction + , revFileTransaction = bcToGrowOpts getRevFileTransaction + , filePosting = bcToGrowOpts getFilePosting + , revFilePosting = bcToGrowOpts getRevFilePosting + , filtered = bcToGrowOpts getFiltered + , revFiltered = bcToGrowOpts getRevFiltered + , sorted = bcToGrowOpts getSorted + , revSorted = bcToGrowOpts getRevSorted + , visible = bcToGrowOpts getVisible + , revVisible = bcToGrowOpts getRevVisible + , lineNum = bcToGrowOpts getLineNum + , date = \o -> getDate (baseColors o) (dateFormat o) + , flag = bcToGrowOpts getFlag + , number = bcToGrowOpts getNumber + , postingDrCr = dcToGrowOpts getPostingDrCr + , postingCmdty = dcToGrowOpts getPostingCmdty + , postingQty = let fn o = + let fmt = qtyFormat o + dc = drCrColors o + in getPostingQty fmt dc + in fn + , totalDrCr = dcToGrowOpts getTotalDrCr + , totalCmdty = dcToGrowOpts getTotalCmdty + , totalQty = let fn o = + let fmt = balanceFormat o + dc = drCrColors o + in getTotalQty fmt dc + in fn } + -- | Make a left justified cell one line long that shows a serial. serialCellMaybe :: (L.PostFam -> Maybe Int) -- ^ When applied to a Box, this function returns Just Int if the -- box has a serial, or Nothing if not. - -> Options.T -> Box -> PreSpec -serialCellMaybe f os b = oneLine t os b + -> CC.BaseColors -> Box -> PreSpec +serialCellMaybe f bc b = oneLine t bc b where t = case f (L.boxPostFam b) of Nothing -> X.empty @@ -120,91 +152,90 @@ serialCell :: (M.PostMeta -> Int) - -> Options.T -> Box -> PreSpec -serialCell f os b = oneLine t os b + -> CC.BaseColors -> Box -> PreSpec +serialCell f bc b = oneLine t bc b where t = pack . show . f . L.boxMeta $ b -getGlobalTransaction :: Options.T -> Box -> PreSpec +getGlobalTransaction :: CC.BaseColors -> Box -> PreSpec getGlobalTransaction = serialCellMaybe (fmap (L.forward . L.unGlobalTransaction) . Q.globalTransaction) -getRevGlobalTransaction :: Options.T -> Box -> PreSpec +getRevGlobalTransaction :: CC.BaseColors -> Box -> PreSpec getRevGlobalTransaction = serialCellMaybe (fmap (L.backward . L.unGlobalTransaction) . Q.globalTransaction) -getGlobalPosting :: Options.T -> Box -> PreSpec +getGlobalPosting :: CC.BaseColors -> Box -> PreSpec getGlobalPosting = serialCellMaybe (fmap (L.forward . L.unGlobalPosting) . Q.globalPosting) -getRevGlobalPosting :: Options.T -> Box -> PreSpec +getRevGlobalPosting :: CC.BaseColors -> Box -> PreSpec getRevGlobalPosting = serialCellMaybe (fmap (L.backward . L.unGlobalPosting) . Q.globalPosting) -getFileTransaction :: Options.T -> Box -> PreSpec +getFileTransaction :: CC.BaseColors -> Box -> PreSpec getFileTransaction = serialCellMaybe (fmap (L.forward . L.unFileTransaction) . Q.fileTransaction) -getRevFileTransaction :: Options.T -> Box -> PreSpec +getRevFileTransaction :: CC.BaseColors -> Box -> PreSpec getRevFileTransaction = serialCellMaybe (fmap (L.backward . L.unFileTransaction) . Q.fileTransaction) -getFilePosting :: Options.T -> Box -> PreSpec +getFilePosting :: CC.BaseColors -> Box -> PreSpec getFilePosting = serialCellMaybe (fmap (L.forward . L.unFilePosting) . Q.filePosting) -getRevFilePosting :: Options.T -> Box -> PreSpec +getRevFilePosting :: CC.BaseColors -> Box -> PreSpec getRevFilePosting = serialCellMaybe (fmap (L.backward . L.unFilePosting) . Q.filePosting) -getSorted :: Options.T -> Box -> PreSpec +getSorted :: CC.BaseColors -> Box -> PreSpec getSorted = serialCell (L.forward . Ly.unSortedNum . M.sortedNum) -getRevSorted :: Options.T -> Box -> PreSpec +getRevSorted :: CC.BaseColors -> Box -> PreSpec getRevSorted = serialCell (L.backward . Ly.unSortedNum . M.sortedNum) -getFiltered :: Options.T -> Box -> PreSpec +getFiltered :: CC.BaseColors -> Box -> PreSpec getFiltered = serialCell (L.forward . Ly.unFilteredNum . M.filteredNum) -getRevFiltered :: Options.T -> Box -> PreSpec +getRevFiltered :: CC.BaseColors -> Box -> PreSpec getRevFiltered = serialCell (L.backward . Ly.unFilteredNum . M.filteredNum) -getVisible :: Options.T -> Box -> PreSpec +getVisible :: CC.BaseColors -> Box -> PreSpec getVisible = serialCell (L.forward . M.unVisibleNum . M.visibleNum) -getRevVisible :: Options.T -> Box -> PreSpec +getRevVisible :: CC.BaseColors -> Box -> PreSpec getRevVisible = serialCell (L.backward . M.unVisibleNum . M.visibleNum) -getLineNum :: Options.T -> Box -> PreSpec -getLineNum os b = oneLine t os b where +getLineNum :: CC.BaseColors -> Box -> PreSpec +getLineNum bc b = oneLine t bc b where lineTxt = pack . show . L.unPostingLine t = maybe empty lineTxt (Q.postingLine . L.boxPostFam $ b) -getDate :: Options.T -> Box -> PreSpec -getDate os i = oneLine t os i where - t = O.dateFormat os i +getDate :: CC.BaseColors -> (Box -> X.Text) -> Box -> PreSpec +getDate bc gd b = oneLine (gd b) bc b -getFlag :: Options.T -> Box -> PreSpec -getFlag os i = oneLine t os i where +getFlag :: CC.BaseColors -> Box -> PreSpec +getFlag bc i = oneLine t bc i where t = maybe empty L.text (Q.flag . L.boxPostFam $ i) -getNumber :: Options.T -> Box -> PreSpec -getNumber os i = oneLine t os i where +getNumber :: CC.BaseColors -> Box -> PreSpec +getNumber bc i = oneLine t bc i where t = maybe empty L.text (Q.number . L.boxPostFam $ i) dcTxt :: L.DrCr -> Text @@ -213,126 +244,131 @@ -- | Gives a one-line cell that is colored according to whether the -- posting is a debit or credit. -coloredPostingCell :: Text -> Options.T -> Box -> PreSpec -coloredPostingCell t os i = PreSpec j ts [bit] where +coloredPostingCell :: Text -> CC.DrCrColors -> Box -> PreSpec +coloredPostingCell t dccol i = PreSpec j ts [bit] where j = R.LeftJustify bit = C.chunk ts t dc = Q.drCr . L.boxPostFam $ i - ts = PC.colors (M.visibleNum . L.boxMeta $ i) - . PC.drCrToBaseColors dc - . O.drCrColors - $ os + ts = CC.colors (M.visibleNum . L.boxMeta $ i) + . CC.drCrToBaseColors dc + $ dccol -getPostingDrCr :: Options.T -> Box -> PreSpec -getPostingDrCr os i = coloredPostingCell t os i where + +getPostingDrCr :: CC.DrCrColors -> Box -> PreSpec +getPostingDrCr dc i = coloredPostingCell t dc i where t = dcTxt . Q.drCr . L.boxPostFam $ i -getPostingCmdty :: Options.T -> Box -> PreSpec -getPostingCmdty os i = coloredPostingCell t os i where +getPostingCmdty :: CC.DrCrColors -> Box -> PreSpec +getPostingCmdty dc i = coloredPostingCell t dc i where t = L.text . L.Delimited (X.singleton ':') . L.textList . Q.commodity . L.boxPostFam $ i -getPostingQty :: Options.T -> Box -> PreSpec -getPostingQty os i = coloredPostingCell t os i where - t = O.qtyFormat os i +getPostingQty :: (Box -> X.Text) -> CC.DrCrColors -> Box -> PreSpec +getPostingQty qf dc i = coloredPostingCell (qf i) dc i -getTotalDrCr :: Options.T -> Box -> PreSpec -getTotalDrCr os i = let - vn = M.visibleNum . L.boxMeta $ i - ts = PC.colors vn bc - bc = PC.drCrToBaseColors dc (O.drCrColors os) - dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> let - spec = PC.noBalanceColors vn (O.drCrColors os) - in [C.chunk spec (pack "--")] - Just bal -> let - toBit bl = let - spec = - PC.colors vn - . PC.bottomLineToBaseColors (O.drCrColors os) - $ bl - txt = case bl of - L.Zero -> pack "--" - L.NonZero (L.Column clmDrCr _) -> dcTxt clmDrCr - in C.chunk spec txt - in fmap toBit . elems . L.unBalance $ bal - j = R.LeftJustify +getTotalDrCr :: CC.DrCrColors -> Box -> PreSpec +getTotalDrCr dccol i = + let vn = M.visibleNum . L.boxMeta $ i + ts = CC.colors vn bc + bc = CC.drCrToBaseColors dc dccol + dc = Q.drCr . L.boxPostFam $ i + bits = case M.balance . L.boxMeta $ i of + Nothing -> + let spec = CC.noBalanceColors vn dccol + in [C.chunk spec (pack "--")] + Just bal -> + let toBit bl = + let spec = + CC.colors vn + . CC.bottomLineToBaseColors dccol + $ bl + txt = case bl of + L.Zero -> pack "--" + L.NonZero (L.Column clmDrCr _) -> + dcTxt clmDrCr + in C.chunk spec txt + in fmap toBit . elems . L.unBalance $ bal + j = R.LeftJustify in PreSpec j ts bits -getTotalCmdty :: Options.T -> Box -> PreSpec -getTotalCmdty os i = let - vn = M.visibleNum . L.boxMeta $ i - j = R.RightJustify - ts = PC.colors vn bc - bc = PC.drCrToBaseColors dc (O.drCrColors os) - dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> let - spec = PC.noBalanceColors vn (O.drCrColors os) - in [C.chunk spec (pack "--")] - Just bal -> let - toBit (com, nou) = let - spec = - PC.colors vn - . PC.bottomLineToBaseColors (O.drCrColors os) - $ nou - txt = L.text - . L.Delimited (X.singleton ':') - . L.textList - $ com - in C.chunk spec txt - in fmap toBit . assocs . L.unBalance $ bal +getTotalCmdty :: CC.DrCrColors -> Box -> PreSpec +getTotalCmdty dccol i = + let vn = M.visibleNum . L.boxMeta $ i + j = R.RightJustify + ts = CC.colors vn bc + bc = CC.drCrToBaseColors dc dccol + dc = Q.drCr . L.boxPostFam $ i + bits = case M.balance . L.boxMeta $ i of + Nothing -> + let spec = CC.noBalanceColors vn dccol + in [C.chunk spec (pack "--")] + Just bal -> + let toBit (com, nou) = + let spec = + CC.colors vn + . CC.bottomLineToBaseColors dccol + $ nou + txt = L.text + . L.Delimited (X.singleton ':') + . L.textList + $ com + in C.chunk spec txt + in fmap toBit . assocs . L.unBalance $ bal in PreSpec j ts bits -getTotalQty :: Options.T -> Box -> PreSpec -getTotalQty os i = let - vn = M.visibleNum . L.boxMeta $ i - j = R.LeftJustify - ts = PC.colors vn bc - bc = PC.drCrToBaseColors dc (O.drCrColors os) - dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> let - spec = PC.noBalanceColors vn (O.drCrColors os) - in [C.chunk spec (pack "--")] - Just bal -> fmap toChunk . assocs . L.unBalance $ bal where - toChunk (com, nou) = let - spec = - PC.colors vn - . PC.bottomLineToBaseColors (O.drCrColors os) - $ nou - txt = O.balanceFormat os com nou - in C.chunk spec txt +getTotalQty :: + (L.Commodity -> L.BottomLine -> X.Text) + -> CC.DrCrColors + -> Box + -> PreSpec +getTotalQty balFmt dccol i = + let vn = M.visibleNum . L.boxMeta $ i + j = R.LeftJustify + ts = CC.colors vn bc + bc = CC.drCrToBaseColors dc dccol + dc = Q.drCr . L.boxPostFam $ i + bits = case M.balance . L.boxMeta $ i of + Nothing -> + let spec = CC.noBalanceColors vn dccol + in [C.chunk spec (pack "--")] + Just bal -> + fmap toChunk . assocs . L.unBalance $ bal + where + toChunk (com, nou) = + let spec = + CC.colors vn + . CC.bottomLineToBaseColors dccol + $ nou + txt = balFmt com nou + in C.chunk spec txt in PreSpec j ts bits -growingFields :: Options.T -> Fields Bool -growingFields o = let - f = O.fields o in Fields { - globalTransaction = F.globalTransaction f - , revGlobalTransaction = F.revGlobalTransaction f - , globalPosting = F.globalPosting f - , revGlobalPosting = F.revGlobalPosting f - , fileTransaction = F.fileTransaction f - , revFileTransaction = F.revFileTransaction f - , filePosting = F.filePosting f - , revFilePosting = F.revFilePosting f - , filtered = F.filtered f - , revFiltered = F.revFiltered f - , sorted = F.sorted f - , revSorted = F.revSorted f - , visible = F.visible f - , revVisible = F.revVisible f - , lineNum = F.lineNum f - , date = F.date f - , flag = F.flag f - , number = F.number f - , postingDrCr = F.postingDrCr f - , postingCmdty = F.postingCmdty f - , postingQty = F.postingQty f - , totalDrCr = F.totalDrCr f - , totalCmdty = F.totalCmdty f - , totalQty = F.totalQty f } +growingFields :: F.Fields Bool -> Fields Bool +growingFields f = Fields { + globalTransaction = F.globalTransaction f + , revGlobalTransaction = F.revGlobalTransaction f + , globalPosting = F.globalPosting f + , revGlobalPosting = F.revGlobalPosting f + , fileTransaction = F.fileTransaction f + , revFileTransaction = F.revFileTransaction f + , filePosting = F.filePosting f + , revFilePosting = F.revFilePosting f + , filtered = F.filtered f + , revFiltered = F.revFiltered f + , sorted = F.sorted f + , revSorted = F.revSorted f + , visible = F.visible f + , revVisible = F.revVisible f + , lineNum = F.lineNum f + , date = F.date f + , flag = F.flag f + , number = F.number f + , postingDrCr = F.postingDrCr f + , postingCmdty = F.postingCmdty f + , postingQty = F.postingQty f + , totalDrCr = F.totalDrCr f + , totalCmdty = F.totalCmdty f + , totalQty = F.totalQty f } -- | All growing fields, as an ADT. data EFields = @@ -529,7 +565,7 @@ -- | Pairs data from a Fields with its matching spacer field. The -- spacer field is returned in a Maybe because the TotalQty field does -- not have a spacer. -pairWithSpacer :: Fields a -> Spacers.T b -> Fields (a, Maybe b) +pairWithSpacer :: Fields a -> S.Spacers b -> Fields (a, Maybe b) pairWithSpacer f s = Fields { globalTransaction = (globalTransaction f, Just (S.globalTransaction s)) , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s)) @@ -588,7 +624,7 @@ -- spacer cells. grownWidth :: Fields (Maybe Int) - -> Spacers.T Int + -> S.Spacers Int -> Int grownWidth fs ss = Semi.getSum diff --git a/Penny/Cabin/Posts/Meta.hs b/Penny/Cabin/Posts/Meta.hs --- a/Penny/Cabin/Posts/Meta.hs +++ b/Penny/Cabin/Posts/Meta.hs @@ -1,18 +1,20 @@ module Penny.Cabin.Posts.Meta ( M.VisibleNum(M.unVisibleNum) , PostMeta(filteredNum, sortedNum, visibleNum, balance) - , filterBoxes - , addMetadata + , Box + , toBoxList ) where import Data.List (mapAccumL) import qualified Penny.Lincoln as L import qualified Penny.Lincoln.Queries as Q import qualified Penny.Liberty as Ly -import qualified Penny.Liberty.Expressions as Exp import qualified Penny.Cabin.Meta as M import qualified Penny.Cabin.Options as CO +-- | The Box type that is used throughout the Posts modules. +type Box = L.Box PostMeta + data PostMeta = PostMeta { filteredNum :: Ly.FilteredNum , sortedNum :: Ly.SortedNum @@ -21,31 +23,38 @@ deriving Show --- | Takes a list of Box with LibertyMeta, and a list of tokens from --- the command line, and a list of post filters. Filters the list of --- Box and processes the post filter. Fails if the expression fails to --- produce a result. -filterBoxes :: - [Exp.Token (L.Box Ly.LibertyMeta -> Bool)] - -> [Ly.PostFilterFn] - -> [L.Box Ly.LibertyMeta] - -> Maybe [L.Box Ly.LibertyMeta] -filterBoxes tks pfs bs = fmap fltr (Ly.parsePredicate tks) - where - fltr p = - Ly.processPostFilters pfs . filter p $ bs - - - --- | Applied to a list of Box that have already been filtered, returns --- a list of Box with posting metadata. addMetadata :: - CO.ShowZeroBalances - -> [L.Box Ly.LibertyMeta] - -> [L.Box PostMeta] -addMetadata szb = M.visibleNums f . addBalances szb where + [(L.Box (Ly.LibertyMeta, Maybe L.Balance))] + -> [Box] +addMetadata = M.visibleNums f where f vn (lm, mb) = PostMeta (Ly.filteredNum lm) (Ly.sortedNum lm) vn mb + +-- | Adds appropriate metadata, including the running balance, to a +-- list of Box. Because all posts are incorporated into the running +-- balance, first calculates the running balance for all posts. Then, +-- removes posts we're not interested in by applying the predicate and +-- the post-filter. Finally, adds on the metadata, which will include +-- the VisibleNum. +toBoxList :: + CO.ShowZeroBalances + -> (L.Box Ly.LibertyMeta -> Bool) + -- ^ Removes posts from the report if applying this function to the + -- post returns False. Posts removed still affect the running + -- balance. + + -> [Ly.PostFilterFn] + -- ^ Applies these post-filters to the list of posts that results + -- from applying the predicate above. Might remove more + -- postings. Postings removed still affect the running balance. + + -> [L.Box Ly.LibertyMeta] + -> [Box] +toBoxList szb pdct pff = + addMetadata + . Ly.processPostFilters pff + . filter (pdct . fmap fst) + . addBalances szb addBalances :: CO.ShowZeroBalances diff --git a/Penny/Cabin/Posts/Options.hs b/Penny/Cabin/Posts/Options.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Options.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | Options for the Posts report. -module Penny.Cabin.Posts.Options where - - -import Control.Monad.Exception.Synchronous (Exceptional) -import Data.Text (Text) -import qualified Data.Text as X -import Data.Time (formatTime) -import System.Locale (defaultTimeLocale) -import qualified Data.Time as Time -import qualified Text.Matchers.Text as M - -import qualified Penny.Liberty as Ly -import qualified Penny.Liberty.Expressions as Ex -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Balance as Bal -import qualified Penny.Lincoln.Bits as Bits -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Cabin.Posts.Allocate as A -import qualified Penny.Cabin.Chunk as CC -import qualified Penny.Cabin.Colors as C -import qualified Penny.Cabin.Options as O -import qualified Penny.Cabin.Posts.Fields as Fields -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Meta as Meta -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Posts.Spacers as Spacers -import qualified Penny.Cabin.Colors.DarkBackground as Dark -import Penny.Copper.DateTime (DefaultTimeZone) -import Penny.Copper.Qty (RadGroup) -import qualified Penny.Shield as S - - -type Box = L.Box Meta.PostMeta - -data T = - T { drCrColors :: C.DrCrColors - -- ^ Colors to use when displaying debits, credits, and - -- when displaying balance totals - - , baseColors :: C.BaseColors - -- ^ Colors to use when displaying everything else - - , dateFormat :: Box -> X.Text - -- ^ How to display dates. This function is applied to the - -- a PostingInfo so it has lots of information, but it - -- should return a date for use in the Date field. - - , qtyFormat :: Box -> X.Text - -- ^ How to display the quantity of the posting. This - -- function is applied to a PostingInfo so it has lots of - -- information, but it should return a formatted string of - -- the quantity. Allows you to format digit grouping, - -- radix points, perform rounding, etc. - - , balanceFormat :: Bits.Commodity -> Bal.BottomLine -> X.Text - -- ^ How to display balance totals. Similar to - -- balanceFormat. - - , payeeAllocation :: A.Allocation - -- ^ This and accountAllocation determine how much space - -- payees and accounts receive. They divide up the - -- remaining space after everything else is displayed. For - -- instance if payeeAllocation is 60 and accountAllocation - -- is 40, the payee takes about 60 percent of the - -- remaining space and the account takes about 40 percent. - - , accountAllocation :: A.Allocation - -- ^ See payeeAllocation above - - , width :: ReportWidth - -- ^ Gives the default report width. This can be - -- overridden on the command line. You can use the - -- information from the Runtime to make this as wide as - -- the as the current terminal. - - , subAccountLength :: Int - -- ^ When shortening the names of sub accounts to make - -- them fit, they will be this long. - - , colorPref :: CC.Colors - -- ^ How many colors you want to see, or do it - -- automatically. - - , timeZone :: DefaultTimeZone - -- ^ When dates and times are given on the command line - -- and they have no time zone, they are assumed to be in - -- this time zone. This has no bearing on how dates are - -- formatted in the output; for that, see dateFormat - -- above. - - , radGroup :: RadGroup - -- ^ The characters used for the radix point for numbers - -- given on the command line (e.g. a full stop, or a - -- comma) and for the digit group separator for - -- numbers parsed from the command line (e.g. a full stop, - -- or a comma). Affects how inputs are parsed. Has no bearing - -- on how output is formatted; for that, see qtyFormat and - -- balanceFormat above. - - , sensitive :: M.CaseSensitive - -- ^ Whether pattern matches are case sensitive by default. - - , factory :: M.CaseSensitive - -> Text -> Exceptional Text (Text -> Bool) - -- ^ Default factory for pattern matching - - , tokens :: [Ex.Token (L.Box Ly.LibertyMeta -> Bool)] - -- ^ Default list of tokens used to filter postings. - - , postFilter :: [Ly.PostFilterFn] - -- ^ The entire posting list is transformed by this - -- function after it is filtered according to the tokens. - - , fields :: Fields.T Bool - -- ^ Default fields to show in the report. - - , spacers :: Spacers.T Int - -- ^ Default width for spacer fields. If any of these Ints are - -- less than or equal to zero, there will be no spacer. There is - -- never a spacer for fields that do not appear in the report. - - , showZeroBalances :: O.ShowZeroBalances - } - -newtype ReportWidth = ReportWidth { unReportWidth :: Int } - deriving (Eq, Show, Ord) - -ymd :: Box -> X.Text -ymd p = X.pack (formatTime defaultTimeLocale fmt d) where - d = Time.localDay - . Bits.localTime - . Q.dateTime - . L.boxPostFam - $ p - fmt = "%Y-%m-%d" - -qtyAsIs :: Box -> X.Text -qtyAsIs p = X.pack . show . Bits.unQty . Q.qty . L.boxPostFam $ p - -balanceAsIs :: Bits.Commodity -> Bal.BottomLine -> X.Text -balanceAsIs _ n = case n of - Bal.Zero -> X.pack "--" - Bal.NonZero c -> X.pack . show . Bits.unQty . Bal.qty $ c - -defaultWidth :: ReportWidth -defaultWidth = ReportWidth 80 - -columnsVarToWidth :: Maybe String -> ReportWidth -columnsVarToWidth ms = case ms of - Nothing -> defaultWidth - Just str -> case reads str of - [] -> defaultWidth - (i, []):[] -> if i > 0 then ReportWidth i else defaultWidth - _ -> defaultWidth - -defaultOptions :: - DefaultTimeZone - -> RadGroup - -> S.Runtime - -> T -defaultOptions dtz rg rt = - T { drCrColors = Dark.drCrColors - , baseColors = Dark.baseColors - , dateFormat = ymd - , qtyFormat = qtyAsIs - , balanceFormat = balanceAsIs - , payeeAllocation = A.allocation 40 - , accountAllocation = A.allocation 60 - , width = widthFromRuntime rt - , subAccountLength = 2 - , colorPref = O.autoColors O.PrefAuto rt - , timeZone = dtz - , radGroup = rg - , sensitive = M.Insensitive - , factory = \s t -> (return (M.within s t)) - , tokens = [] - , postFilter = [] - , fields = defaultFields - , spacers = defaultSpacerWidth - , showZeroBalances = O.ShowZeroBalances False } - -widthFromRuntime :: S.Runtime -> ReportWidth -widthFromRuntime rt = case S.screenWidth rt of - Nothing -> defaultWidth - Just w -> ReportWidth . S.unScreenWidth $ w - -defaultFields :: Fields.T Bool -defaultFields = - Fields.T { 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 :: Spacers.T Int -defaultSpacerWidth = - Spacers.T { 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 } - diff --git a/Penny/Cabin/Posts/Parser.hs b/Penny/Cabin/Posts/Parser.hs --- a/Penny/Cabin/Posts/Parser.hs +++ b/Penny/Cabin/Posts/Parser.hs @@ -1,24 +1,28 @@ -module Penny.Cabin.Posts.Parser (parseOptions) where +module Penny.Cabin.Posts.Parser (State(..), parseOptions, + Error(..)) where -import Control.Applicative ((<|>), (<$>), pure, many, (<*>)) +import Control.Applicative ((<|>), (<$>), pure, many, (<*>), + Applicative) import Control.Monad ((>=>)) import qualified Control.Monad.Exception.Synchronous as Ex import Data.Char (toLower) -import qualified Data.Foldable as F +import qualified Data.Foldable as Fdbl import qualified System.Console.MultiArg.Combinator as C import System.Console.MultiArg.Prim (Parser) import qualified Penny.Cabin.Chunk as CC import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Posts.Fields as Fl -import qualified Penny.Cabin.Posts.Options as Op +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Types as Ty import qualified Penny.Cabin.Colors.DarkBackground as DB import qualified Penny.Cabin.Colors.LightBackground as LB import qualified Penny.Cabin.Options as CO +import qualified Penny.Copper as Cop import qualified Penny.Liberty as Ly import qualified Penny.Liberty.Expressions as Exp import qualified Penny.Lincoln as L import qualified Penny.Shield as S +import qualified Text.Matchers.Text as M data Error = BadColorName String | BadBackgroundArg String @@ -30,56 +34,85 @@ | BadComparator String deriving Show +data State = State { + sensitive :: M.CaseSensitive + , factory :: L.Factory + , tokens :: [Ly.Token (L.Box Ly.LibertyMeta -> Bool)] + , postFilter :: [Ly.PostFilterFn] + , fields :: F.Fields Bool + , colorPref :: CC.Colors + , drCrColors :: PC.DrCrColors + , baseColors :: PC.BaseColors + , width :: Ty.ReportWidth + , showZeroBalances :: CO.ShowZeroBalances + } + -- | Parses the command line from the first word remaining up until, -- but not including, the first non-option argment. parseOptions :: - Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T) + Parser (S.Runtime + -> Cop.DefaultTimeZone + -> Cop.RadGroup + -> State + -> Ex.Exceptional Error State) parseOptions = f <$> many parseOption where f ls = - let g rt op = - let ls' = map (\fn -> fn rt) ls - in (foldl (>=>) return ls') op + let g rt dtz rg st = + let ls' = map (\fn -> fn rt dtz rg) ls + in (foldl (>=>) return ls') st in g parseOption :: - Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T) + Parser (S.Runtime + -> Cop.DefaultTimeZone + -> Cop.RadGroup + -> State + -> Ex.Exceptional Error State) parseOption = operand - <|> mkTwoArg boxFilters - <|> mkTwoArg postFilter - <|> mkTwoArg matcherSelect - <|> mkTwoArg caseSelect - <|> mkTwoArg operator - <|> color - <|> mkTwoArg background - <|> mkTwoArg width - <|> mkTwoArg showField - <|> mkTwoArg hideField - <|> mkTwoArg showAllFields - <|> mkTwoArg hideAllFields - <|> mkTwoArg showZeroBalances - <|> mkTwoArg hideZeroBalances + <|> wrap boxFilters + <|> wrap parsePostFilter + <|> wrap (impurify matcherSelect) + <|> wrap (impurify caseSelect) + <|> wrap (impurify operator) + <|> (do { f <- color; return (\rt _ _ st -> f rt st)}) + <|> wrap background + <|> wrap parseWidth + <|> wrap showField + <|> wrap hideField + <|> wrap (impurify showAllFields) + <|> wrap (impurify hideAllFields) + <|> wrap (impurify parseShowZeroBalances) + <|> wrap (impurify hideZeroBalances) where - mkTwoArg p = do + wrap p = do f <- p - return (\_ o -> f o) + return (\_ _ _ st -> f st) -operand :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T) +impurify :: + (Functor f, Applicative m) + => f (a -> b) + -> f (a -> m b) +impurify = fmap (\g -> pure . g) + +operand :: Parser (S.Runtime + -> Cop.DefaultTimeZone + -> Cop.RadGroup + -> State + -> Ex.Exceptional Error State) operand = f <$> Ly.parseOperand where - f lyFn rt op = - let dtz = Op.timeZone op - rg = Op.radGroup op - dt = S.currentTime rt - cs = Op.sensitive op - fty = Op.factory op + f lyFn rt dtz rg st = + let dt = S.currentTime rt + cs = sensitive st + fty = factory st in case lyFn dt dtz rg cs fty of Ex.Exception e -> Ex.throw . LibertyError $ e Ex.Success (Exp.Operand g) -> let g' = g . L.boxPostFam - ts' = Op.tokens op ++ [Exp.TokOperand g'] - in return op { Op.tokens = ts' } + ts' = tokens st ++ [Exp.TokOperand g'] + in return st { tokens = ts' } -- | Processes a option for box-level serials. optBoxSerial :: @@ -92,35 +125,35 @@ -> (Ly.LibertyMeta -> Int) -- ^ Pulls the serial from the PostMeta - -> Parser (Op.T -> Ex.Exceptional Error Op.T) + -> Parser (State -> Ex.Exceptional Error State) optBoxSerial ls ss f = parseOpt ls ss (C.TwoArg g) where - g a1 a2 op = do + g a1 a2 st = do cmp <- Ex.fromMaybe (BadComparator a1) (Ly.parseComparer a1) i <- parseInt a2 let h box = let ser = f . L.boxMeta $ box in ser `cmp` i tok = Exp.TokOperand h - return op { Op.tokens = Op.tokens op ++ [tok] } + return st { tokens = tokens st ++ [tok] } -optFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T) +optFilteredNum :: Parser (State -> Ex.Exceptional Error State) optFilteredNum = optBoxSerial ["filtered"] "" f where f = L.forward . Ly.unFilteredNum . Ly.filteredNum -optRevFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T) +optRevFilteredNum :: Parser (State -> Ex.Exceptional Error State) optRevFilteredNum = optBoxSerial ["revFiltered"] "" f where f = L.backward . Ly.unFilteredNum . Ly.filteredNum -optSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T) +optSortedNum :: Parser (State -> Ex.Exceptional Error State) optSortedNum = optBoxSerial ["sorted"] "" f where f = L.forward . Ly.unSortedNum . Ly.sortedNum -optRevSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T) +optRevSortedNum :: Parser (State -> Ex.Exceptional Error State) optRevSortedNum = optBoxSerial ["revSorted"] "" f where f = L.backward . Ly.unSortedNum . Ly.sortedNum @@ -130,7 +163,7 @@ (i, ""):[] -> return i _ -> Ex.throw . BadNumber $ s -boxFilters :: Parser (Op.T -> Ex.Exceptional Error Op.T) +boxFilters :: Parser (State -> Ex.Exceptional Error State) boxFilters = optFilteredNum <|> optRevFilteredNum @@ -138,39 +171,39 @@ <|> optRevSortedNum -postFilter :: Parser (Op.T -> Ex.Exceptional Error Op.T) -postFilter = f <$> Ly.parsePostFilter +parsePostFilter :: Parser (State -> Ex.Exceptional Error State) +parsePostFilter = f <$> Ly.parsePostFilter where - f ex op = + f ex st = case ex of Ex.Exception e -> Ex.throw . LibertyError $ e Ex.Success pf -> - return op { Op.postFilter = Op.postFilter op ++ [pf] } + return st { postFilter = postFilter st ++ [pf] } -matcherSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T) +matcherSelect :: Parser (State -> State) matcherSelect = f <$> Ly.parseMatcherSelect where - f mf op = return op { Op.factory = mf } + f mf st = st { factory = mf } -caseSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T) +caseSelect :: Parser (State -> State) caseSelect = f <$> Ly.parseCaseSelect where - f cs op = return op { Op.sensitive = cs } + f cs st = st { sensitive = cs } -operator :: Parser (Op.T -> Ex.Exceptional Error Op.T) +operator :: Parser (State -> State) operator = f <$> Ly.parseOperator where - f oo op = return op { Op.tokens = Op.tokens op ++ [oo] } + f oo st = st { tokens = tokens st ++ [oo] } parseOpt :: [String] -> [Char] -> C.ArgSpec a -> Parser a parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a] -color :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T) +color :: Parser (S.Runtime -> State -> Ex.Exceptional Error State) color = parseOpt ["color"] "" (C.OneArg f) where - f a1 rt op = case pickColorArg rt a1 of + f a1 rt st = case pickColorArg rt a1 of Nothing -> Ex.throw . BadColorName $ a1 - Just c -> return (op { Op.colorPref = c }) + Just c -> return (st { colorPref = c }) pickColorArg :: S.Runtime -> String -> Maybe CC.Colors pickColorArg rt t @@ -187,84 +220,83 @@ | otherwise = Nothing -background :: Parser (Op.T -> Ex.Exceptional Error Op.T) +background :: Parser (State -> Ex.Exceptional Error State) background = parseOpt ["background"] "" (C.OneArg f) where - f a1 op = case pickBackgroundArg a1 of + f a1 st = case pickBackgroundArg a1 of Nothing -> Ex.throw . BadBackgroundArg $ a1 - Just (dc, bc) -> return (op { Op.drCrColors = dc - , Op.baseColors = bc } ) + Just (dc, bc) -> return (st { drCrColors = dc + , baseColors = bc } ) -width :: Parser (Op.T -> Ex.Exceptional Error Op.T) -width = parseOpt ["width"] "" (C.OneArg f) +parseWidth :: Parser (State -> Ex.Exceptional Error State) +parseWidth = parseOpt ["width"] "" (C.OneArg f) where - f a1 op = case reads a1 of - (i, ""):[] -> return (op { Op.width = Op.ReportWidth i }) + f a1 st = case reads a1 of + (i, ""):[] -> return (st { width = Ty.ReportWidth i }) _ -> Ex.throw . BadWidthArg $ a1 -showField :: Parser (Op.T -> Ex.Exceptional Error Op.T) +showField :: Parser (State -> Ex.Exceptional Error State) showField = parseOpt ["show"] "" (C.OneArg f) where - f a1 op = do + f a1 st = do fl <- parseField a1 - let newFl = fieldOn (Op.fields op) fl - return op { Op.fields = newFl } + let newFl = fieldOn (fields st) fl + return st { fields = newFl } -hideField :: Parser (Op.T -> Ex.Exceptional Error Op.T) +hideField :: Parser (State -> Ex.Exceptional Error State) hideField = parseOpt ["hide"] "" (C.OneArg f) where - f a1 op = do + f a1 st = do fl <- parseField a1 - let newFl = fieldOff (Op.fields op) fl - return op { Op.fields = newFl } + let newFl = fieldOff (fields st) fl + return st { fields = newFl } -showAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T) +showAllFields :: Parser (State -> State) showAllFields = parseOpt ["show-all"] "" (C.NoArg f) where - f op = return (op {Op.fields = pure True}) + f st = st {fields = pure True} -hideAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T) +hideAllFields :: Parser (State -> State) hideAllFields = parseOpt ["hide-all"] "" (C.NoArg f) where - f op = return (op {Op.fields = pure False}) + f st = st {fields = pure False} -showZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T) -showZeroBalances = parseOpt ["show-zero-balances"] "" (C.NoArg f) +parseShowZeroBalances :: Parser (State -> State) +parseShowZeroBalances = parseOpt opt "" (C.NoArg f) where - f op = - return (op {Op.showZeroBalances = CO.ShowZeroBalances True }) + opt = ["show-zero-balances"] + f st = st {showZeroBalances = CO.ShowZeroBalances True } -hideZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T) +hideZeroBalances :: Parser (State -> State) hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f) where - f op = - return (op {Op.showZeroBalances = CO.ShowZeroBalances False }) + f st = st {showZeroBalances = CO.ShowZeroBalances False } -- | Turns a field on if it is True. fieldOn :: - Fl.T Bool + F.Fields Bool -- ^ Fields as seen so far - -> Fl.T Bool + -> F.Fields Bool -- ^ Record that should have one True element indicating a field -- name seen on the command line; other elements should be False - -> Fl.T Bool + -> F.Fields Bool -- ^ Fields as seen so far, with new field added fieldOn old new = (||) <$> old <*> new -- | Turns off a field if it is True. fieldOff :: - Fl.T Bool + F.Fields Bool -- ^ Fields seen so far - -> Fl.T Bool + -> F.Fields Bool -- ^ Record that should have one True element indicating a field -- name seen on the command line; other elements should be False - -> Fl.T Bool + -> F.Fields Bool -- ^ Fields as seen so far, with new field added fieldOff old new = f <$> old <*> new @@ -272,7 +304,7 @@ f o False = o f _ True = False -parseField :: String -> Ex.Exceptional Error (Fl.T Bool) +parseField :: String -> Ex.Exceptional Error (F.Fields Bool) parseField str = let lower = map toLower str checkField s = @@ -283,44 +315,44 @@ in checkFields flds -- | Checks the fields with the True value to ensure there is only one. -checkFields :: Fl.T (String, Bool) -> Ex.Exceptional Error (Fl.T Bool) +checkFields :: F.Fields (String, Bool) -> Ex.Exceptional Error (F.Fields Bool) checkFields fs = let f (s, b) ls = if b then s:ls else ls - in case F.foldr f [] fs of + in case Fdbl.foldr f [] fs of [] -> Ex.throw NoMatchingFieldName _:[] -> return (snd <$> fs) ls -> Ex.throw . MultipleMatchingFieldNames $ ls -fieldNames :: Fl.T String -fieldNames = Fl.T { - Fl.globalTransaction = "globalTransaction" - , Fl.revGlobalTransaction = "revGlobalTransaction" - , Fl.globalPosting = "globalPosting" - , Fl.revGlobalPosting = "revGlobalPosting" - , Fl.fileTransaction = "fileTransaction" - , Fl.revFileTransaction = "revFileTransaction" - , Fl.filePosting = "filePosting" - , Fl.revFilePosting = "revFilePosting" - , Fl.filtered = "filtered" - , Fl.revFiltered = "revFiltered" - , Fl.sorted = "sorted" - , Fl.revSorted = "revSorted" - , Fl.visible = "visible" - , Fl.revVisible = "revVisible" - , Fl.lineNum = "lineNum" - , Fl.date = "date" - , Fl.flag = "flag" - , Fl.number = "number" - , Fl.payee = "payee" - , Fl.account = "account" - , Fl.postingDrCr = "postingDrCr" - , Fl.postingCmdty = "postingCmdty" - , Fl.postingQty = "postingQty" - , Fl.totalDrCr = "totalDrCr" - , Fl.totalCmdty = "totalCmdty" - , Fl.totalQty = "totalQty" - , Fl.tags = "tags" - , Fl.memo = "memo" - , Fl.filename = "filename" } +fieldNames :: F.Fields String +fieldNames = F.Fields { + F.globalTransaction = "globalTransaction" + , F.revGlobalTransaction = "revGlobalTransaction" + , F.globalPosting = "globalPosting" + , F.revGlobalPosting = "revGlobalPosting" + , F.fileTransaction = "fileTransaction" + , F.revFileTransaction = "revFileTransaction" + , F.filePosting = "filePosting" + , F.revFilePosting = "revFilePosting" + , F.filtered = "filtered" + , F.revFiltered = "revFiltered" + , F.sorted = "sorted" + , F.revSorted = "revSorted" + , F.visible = "visible" + , F.revVisible = "revVisible" + , F.lineNum = "lineNum" + , F.date = "date" + , F.flag = "flag" + , F.number = "number" + , F.payee = "payee" + , F.account = "account" + , F.postingDrCr = "postingDrCr" + , F.postingCmdty = "postingCmdty" + , F.postingQty = "postingQty" + , F.totalDrCr = "totalDrCr" + , F.totalCmdty = "totalCmdty" + , F.totalQty = "totalQty" + , F.tags = "tags" + , F.memo = "memo" + , F.filename = "filename" } diff --git a/Penny/Cabin/Posts/Spacers.hs b/Penny/Cabin/Posts/Spacers.hs --- a/Penny/Cabin/Posts/Spacers.hs +++ b/Penny/Cabin/Posts/Spacers.hs @@ -3,7 +3,7 @@ -- field. module Penny.Cabin.Posts.Spacers where -data T a = T { +data Spacers a = Spacers { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a @@ -31,78 +31,3 @@ , totalDrCr :: a , totalCmdty :: a } deriving (Show, Eq) - -t_globalTransaction :: a -> T a -> T a -t_globalTransaction a f = f { globalTransaction = a } - -t_revGlobalTransaction :: a -> T a -> T a -t_revGlobalTransaction a f = f { revGlobalTransaction = a } - -t_globalPosting :: a -> T a -> T a -t_globalPosting a f = f { globalPosting = a } - -t_revGlobalPosting :: a -> T a -> T a -t_revGlobalPosting a f = f { revGlobalPosting = a } - -t_fileTransaction :: a -> T a -> T a -t_fileTransaction a f = f { fileTransaction = a } - -t_revFileTransaction :: a -> T a -> T a -t_revFileTransaction a f = f { revFileTransaction = a } - -t_filePosting :: a -> T a -> T a -t_filePosting a f = f { filePosting = a } - -t_revFilePosting :: a -> T a -> T a -t_revFilePosting a f = f { revFilePosting = a } - -t_filtered :: a -> T a -> T a -t_filtered a f = f { filtered = a } - -t_revFiltered :: a -> T a -> T a -t_revFiltered a f = f { revFiltered = a } - -t_sorted :: a -> T a -> T a -t_sorted a f = f { sorted = a } - -t_revSorted :: a -> T a -> T a -t_revSorted a f = f { revSorted = a } - -t_visible :: a -> T a -> T a -t_visible a f = f { visible = a } - -t_revVisible :: a -> T a -> T a -t_revVisible a f = f { revVisible = a } - -t_lineNum :: a -> T a -> T a -t_lineNum a f = f { lineNum = a } - -t_date :: a -> T a -> T a -t_date a f = f { date = a } - -t_flag :: a -> T a -> T a -t_flag a f = f { flag = a } - -t_number :: a -> T a -> T a -t_number a f = f { number = a } - -t_payee :: a -> T a -> T a -t_payee a f = f { payee = a } - -t_account :: a -> T a -> T a -t_account a f = f { account = a } - -t_postingDrCr :: a -> T a -> T a -t_postingDrCr a f = f { postingDrCr = a } - -t_postingCmdty :: a -> T a -> T a -t_postingCmdty a f = f { postingCmdty = a } - -t_postingQty :: a -> T a -> T a -t_postingQty a f = f { postingQty = a } - -t_totalDrCr :: a -> T a -> T a -t_totalDrCr a f = f { totalDrCr = a } - -t_totalCmdty :: a -> T a -> T a -t_totalCmdty a f = f { totalCmdty = a } diff --git a/Penny/Cabin/Posts/Types.hs b/Penny/Cabin/Posts/Types.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Posts/Types.hs @@ -0,0 +1,4 @@ +module Penny.Cabin.Posts.Types where + +newtype ReportWidth = ReportWidth { unReportWidth :: Int } + deriving (Eq, Show, Ord) diff --git a/Penny/Lincoln.hs b/Penny/Lincoln.hs --- a/Penny/Lincoln.hs +++ b/Penny/Lincoln.hs @@ -195,6 +195,10 @@ , S.backward , S.serials , S.serialItems + + -- * Matchers + , Matchers.Matcher + , Matchers.Factory ) where @@ -203,6 +207,7 @@ import qualified Penny.Lincoln.Builders as Bd import qualified Penny.Lincoln.Family as F import qualified Penny.Lincoln.HasText as HT +import qualified Penny.Lincoln.Matchers as Matchers import qualified Penny.Lincoln.Meta as M import qualified Penny.Lincoln.PriceDb as DB import qualified Penny.Lincoln.Serial as S diff --git a/Penny/Lincoln/Matchers.hs b/Penny/Lincoln/Matchers.hs new file mode 100644 --- /dev/null +++ b/Penny/Lincoln/Matchers.hs @@ -0,0 +1,23 @@ +-- | Type synonyms for functions dealing with text matching. + +module Penny.Lincoln.Matchers where + +import qualified Data.Text as X +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Text.Matchers.Text as MT + +type Matcher = X.Text -> Bool + +-- | A function that makes Matchers. +type Factory = + MT.CaseSensitive + -- ^ Will this matcher be case sensitive? + + -> X.Text + -- ^ The pattern to use when testing for a match. For example, this + -- might be a regular expression, or simply the text to be matched. + + -> Ex.Exceptional X.Text Matcher + -- ^ Sometimes producing a matcher might fail; for example, the user + -- might have supplied a bad pattern. If so, an exception is + -- returned. On success, a Matcher is returned. diff --git a/penny-lib.cabal b/penny-lib.cabal --- a/penny-lib.cabal +++ b/penny-lib.cabal @@ -1,5 +1,5 @@ Name: penny-lib -Version: 0.2.0.0 +Version: 0.4.0.0 Cabal-version: >=1.8 Build-Type: Simple License: MIT @@ -191,7 +191,6 @@ Penny.Cabin.Balance, Penny.Cabin.Balance.Parser, Penny.Cabin.Balance.Help, - Penny.Cabin.Balance.Options, Penny.Cabin.Balance.Tree, Penny.Cabin.Chunk, Penny.Cabin.Chunk.Switch, @@ -210,9 +209,9 @@ Penny.Cabin.Posts.Chunk, Penny.Cabin.Posts.Help, Penny.Cabin.Posts.Meta, - Penny.Cabin.Posts.Options, Penny.Cabin.Posts.Parser, Penny.Cabin.Posts.Spacers, + Penny.Cabin.Posts.Types, Penny.Cabin.Row, Penny.Cabin.TextFormat, Penny.Copper, @@ -262,6 +261,7 @@ Penny.Lincoln.Family.Family, Penny.Lincoln.Family.Siblings, Penny.Lincoln.HasText, + Penny.Lincoln.Matchers, Penny.Lincoln.Meta, Penny.Lincoln.NestedMap, Penny.Lincoln.Predicates,