module Penny.Cabin.Posts.BottomRows (
BottomOpts(..),
bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers,
topRowCells) where
import Control.Applicative((<$>), Applicative(pure, (<*>)))
import qualified Data.Foldable as Fdbl
import Control.Monad (guard)
import Data.List (intersperse, find)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes)
import Data.Monoid (mappend, mempty, First(First, getFirst))
import qualified Data.Sequence as Seq
import qualified Data.Text as X
import qualified Data.Traversable as T
import qualified Penny.Steel.Chunk as C
import qualified Penny.Cabin.Scheme as E
import qualified Penny.Cabin.Row as R
import qualified Penny.Cabin.TextFormat as TF
import qualified Penny.Cabin.Posts.Allocated as A
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 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
data BottomOpts = BottomOpts
{ growingWidths :: G.Fields (Maybe Int)
, allocatedWidths :: A.Fields (Maybe Int)
, fields :: F.Fields Bool
, reportWidth :: Ty.ReportWidth
, spacers :: S.Spacers Int
}
bottomRows ::
BottomOpts
-> [Box]
-> Fields (Maybe [[E.PreChunk]])
bottomRows os bs = makeRows bs pcs where
pcs = infoProcessors topSpecs (reportWidth os) wanted
wanted = requestedMakers (fields os)
topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os)
(spacers os)
data Fields a = Fields {
tags :: a
, memo :: a
, filename :: a
} deriving (Show, Eq)
instance Fdbl.Foldable Fields where
foldr f z d =
f (tags d)
(f (memo d)
(f (filename d) z))
instance Functor Fields where
fmap f (Fields t m fn) =
Fields (f t) (f m) (f fn)
instance Applicative Fields where
pure a = Fields a a a
ff <*> fa = Fields {
tags = (tags ff) (tags fa)
, memo = (memo ff) (memo fa)
, filename = (filename ff) (filename fa)
}
bottomRowsFields :: F.Fields a -> Fields a
bottomRowsFields f = Fields {
tags = F.tags f
, memo = F.memo f
, filename = F.filename f }
data Hanging a = Hanging {
leftPad :: a
, mainCell :: a
, rightPad :: a
} deriving (Show, Eq)
newtype SpacerWidth = SpacerWidth Int deriving (Show, Eq)
newtype ContentWidth = ContentWidth Int deriving (Show, Eq)
hanging ::
[TopCellSpec]
-> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
-> Box -> [E.PreChunk])
hanging specs = hangingWidths specs
>>= return . hangingInfoProcessor
hangingInfoProcessor ::
Hanging Int
-> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
-> Box
-> [E.PreChunk]
hangingInfoProcessor widths mkr info = row where
row = R.row [left, mid, right]
(ts, mid) = mkr info (mainCell widths)
mkPad w = R.ColumnSpec R.LeftJustify (C.Width w) ts []
left = mkPad (leftPad widths)
right = mkPad (rightPad widths)
widthOfTopColumns ::
[TopCellSpec]
-> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
-> Box -> [E.PreChunk])
widthOfTopColumns ts =
if null ts
then Nothing
else Just $ makeSpecificWidth w where
w = Fdbl.foldl' f 0 ts
f acc (_, maySpcWidth, (ContentWidth cw)) =
acc + cw + maybe 0 (\(SpacerWidth sw) -> sw) maySpcWidth
widthOfReport ::
Ty.ReportWidth
-> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
-> Box
-> [E.PreChunk]
widthOfReport (Ty.ReportWidth rw) fn info =
makeSpecificWidth rw fn info
chooseProcessor ::
[TopCellSpec]
-> Ty.ReportWidth
-> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
-> Box
-> [E.PreChunk]
chooseProcessor specs rw fn = let
firstTwo = First (hanging specs)
`mappend` First (widthOfTopColumns specs)
in case getFirst firstTwo of
Nothing -> widthOfReport rw fn
Just r -> r fn
infoProcessors ::
[TopCellSpec]
-> Ty.ReportWidth
-> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)))
-> Fields (Maybe (Box -> [E.PreChunk]))
infoProcessors specs rw flds = let
chooser = chooseProcessor specs rw
mkProcessor mayFn = case mayFn of
Nothing -> Nothing
Just fn -> Just $ chooser fn
in mkProcessor <$> flds
makeRows ::
[Box]
-> Fields (Maybe (Box -> [E.PreChunk]))
-> Fields (Maybe [[E.PreChunk]])
makeRows is flds = let
mkRow fn = map fn is
in fmap (fmap mkRow) flds
hangingWidths :: [TopCellSpec]
-> Maybe (Hanging Int)
hangingWidths ls = do
let len = length ls
guard (len > 4)
let matchColumn x (c, _, _) = x == c
totDrCr <- find (matchColumn ETotalDrCr) ls
totCmdty <- find (matchColumn ETotalCmdty) ls
totQty <- find (matchColumn ETotalQty) ls
let (first:middle) = take (len 3) ls
mid <- NE.nonEmpty middle
return $ calcHangingWidths first mid (totDrCr, totCmdty, totQty)
type TopCellSpec = (ETopRowCells, Maybe SpacerWidth, ContentWidth)
calcHangingWidths ::
TopCellSpec
-> NE.NonEmpty TopCellSpec
-> (TopCellSpec, TopCellSpec, TopCellSpec)
-> Hanging Int
calcHangingWidths l m r = Hanging left middle right where
calcWidth (_, maybeSp, (ContentWidth c)) =
c + maybe 0 (\(SpacerWidth w) -> abs w) maybeSp
left = calcWidth l
middle = Fdbl.foldl' f 0 m where
f acc c = acc + calcWidth c
(totDrCr, totCmdty, totQty) = r
right = calcWidth totDrCr + calcWidth totCmdty
+ calcWidth totQty
topCellSpecs :: G.Fields (Maybe Int)
-> A.Fields (Maybe Int)
-> S.Spacers Int
-> [TopCellSpec]
topCellSpecs gFlds aFlds spcs = let
allFlds = topRowCells gFlds aFlds
cws = fmap (fmap ContentWidth) allFlds
merged = mergeWithSpacers cws spcs
tripler e (cw, maybeSpc) = (e, (fmap SpacerWidth maybeSpc), cw)
list = Fdbl.toList $ tripler <$> eTopRowCells <*> merged
toMaybe (e, maybeS, maybeC) = case maybeC of
Nothing -> Nothing
Just c -> Just (e, maybeS, c)
in catMaybes (map toMaybe list)
mergeWithSpacers ::
TopRowCells a
-> S.Spacers b
-> TopRowCells (a, Maybe b)
mergeWithSpacers t s = TopRowCells {
globalTransaction = (globalTransaction t, Just (S.globalTransaction s))
, revGlobalTransaction = (revGlobalTransaction t, Just (S.revGlobalTransaction s))
, globalPosting = (globalPosting t, Just (S.globalPosting s))
, revGlobalPosting = (revGlobalPosting t, Just (S.revGlobalPosting s))
, fileTransaction = (fileTransaction t, Just (S.fileTransaction s))
, revFileTransaction = (revFileTransaction t, Just (S.revFileTransaction s))
, filePosting = (filePosting t, Just (S.filePosting s))
, revFilePosting = (revFilePosting t, Just (S.revFilePosting s))
, filtered = (filtered t, Just (S.filtered s))
, revFiltered = (revFiltered t, Just (S.revFiltered s))
, sorted = (sorted t, Just (S.sorted s))
, revSorted = (revSorted t, Just (S.revSorted s))
, visible = (visible t, Just (S.visible s))
, revVisible = (revVisible t, Just (S.revVisible s))
, lineNum = (lineNum t, Just (S.lineNum s))
, date = (date t, Just (S.date s))
, flag = (flag t, Just (S.flag s))
, number = (number t, Just (S.number s))
, payee = (payee t, Just (S.payee s))
, account = (account t, Just (S.account s))
, postingDrCr = (postingDrCr t, Just (S.postingDrCr s))
, postingCmdty = (postingCmdty t, Just (S.postingCmdty s))
, postingQty = (postingQty t, Just (S.postingQty s))
, totalDrCr = (totalDrCr t, Just (S.totalDrCr s))
, totalCmdty = (totalCmdty t, Just (S.totalCmdty s))
, totalQty = (totalQty t, Nothing) }
makeSpecificWidth :: Int -> (Box -> Int -> (a, R.ColumnSpec))
-> Box -> [E.PreChunk]
makeSpecificWidth w f i = R.row [c] where
(_, c) = f i w
type Maker
= Box
-> Int
-> ((E.Label, E.EvenOdd), R.ColumnSpec)
makers :: Fields Maker
makers = Fields tagsCell memoCell filenameCell
requestedMakers ::
F.Fields Bool
-> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)))
requestedMakers allFlds =
let flds = bottomRowsFields allFlds
filler b mkr = if b then Just $ mkr else Nothing
in filler <$> flds <*> makers
tagsCell
:: Box
-> Int
-> ((E.Label, E.EvenOdd), R.ColumnSpec)
tagsCell info w = (ts, cell) where
vn = M.visibleNum . L.boxMeta $ info
cell = R.ColumnSpec R.LeftJustify (C.Width w) ts cs
eo = E.fromVisibleNum vn
ts = (E.Other, eo)
cs =
Fdbl.toList
. fmap toBit
. TF.unLines
. TF.wordWrap w
. TF.Words
. Seq.fromList
. map (X.cons '*')
. HT.textList
. Q.tags
. L.boxPostFam
$ info
toBit (TF.Words ws) = E.PreChunk E.Other eo t where
t = X.concat . intersperse (X.singleton ' ') . Fdbl.toList $ ws
memoBits :: (E.Label, E.EvenOdd) -> L.Memo -> C.Width -> [E.PreChunk]
memoBits (lbl, eo) m (C.Width w) = cs where
cs = Fdbl.toList
. fmap toBit
. TF.unLines
. TF.wordWrap w
. TF.Words
. Seq.fromList
. X.words
. X.intercalate (X.singleton ' ')
. L.unMemo
$ m
toBit (TF.Words ws) = E.PreChunk lbl eo (X.unwords . Fdbl.toList $ ws)
memoCell :: Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)
memoCell info width = (ts, cell) where
w = C.Width width
vn = M.visibleNum . L.boxMeta $ info
eo = E.fromVisibleNum vn
ts = (E.Other, eo)
cell = R.ColumnSpec R.LeftJustify w ts cs
mayPm = Q.postingMemo . L.boxPostFam $ info
mayTm = Q.transactionMemo . L.boxPostFam $ info
cs = case (mayPm, mayTm) of
(Nothing, Nothing) -> mempty
(Nothing, Just tm) -> memoBits ts tm w
(Just pm, Nothing) -> memoBits ts pm w
(Just pm, Just tm) -> memoBits ts pm w `mappend` memoBits ts tm w
filenameCell :: Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)
filenameCell info width = (ts, cell) where
w = C.Width width
vn = M.visibleNum . L.boxMeta $ info
eo = E.fromVisibleNum vn
ts = (E.Other, eo)
cell = R.ColumnSpec R.LeftJustify w ts cs
toBit n = (E.PreChunk E.Other eo)
. X.drop (max 0 (X.length n width)) $ n
cs = case Q.filename . L.boxPostFam $ info of
Nothing -> []
Just fn -> [toBit . L.unFilename $ fn]
data TopRowCells a = TopRowCells
{ globalTransaction :: a
, revGlobalTransaction :: a
, globalPosting :: a
, revGlobalPosting :: a
, fileTransaction :: a
, revFileTransaction :: a
, filePosting :: a
, revFilePosting :: a
, filtered :: a
, revFiltered :: a
, sorted :: a
, revSorted :: a
, visible :: a
, revVisible :: a
, lineNum :: a
, date :: a
, flag :: a
, number :: a
, payee :: a
, account :: a
, postingDrCr :: a
, postingCmdty :: a
, postingQty :: a
, totalDrCr :: a
, totalCmdty :: a
, totalQty :: a }
deriving (Show, Eq)
topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a
topRowCells g a = TopRowCells
{ globalTransaction = G.globalTransaction g
, revGlobalTransaction = G.revGlobalTransaction g
, globalPosting = G.globalPosting g
, revGlobalPosting = G.revGlobalPosting g
, fileTransaction = G.fileTransaction g
, revFileTransaction = G.revFileTransaction g
, filePosting = G.filePosting g
, revFilePosting = G.revFilePosting g
, filtered = G.filtered g
, revFiltered = G.revFiltered g
, sorted = G.sorted g
, revSorted = G.revSorted g
, visible = G.visible g
, revVisible = G.revVisible g
, lineNum = G.lineNum g
, date = G.date g
, flag = G.flag g
, number = G.number g
, payee = A.payee a
, account = A.account a
, postingDrCr = G.postingDrCr g
, postingCmdty = G.postingCmdty g
, postingQty = G.postingQty g
, totalDrCr = G.totalDrCr g
, totalCmdty = G.totalCmdty g
, totalQty = G.totalQty g }
data ETopRowCells =
EGlobalTransaction
| ERevGlobalTransaction
| EGlobalPosting
| ERevGlobalPosting
| EFileTransaction
| ERevFileTransaction
| EFilePosting
| ERevFilePosting
| EFiltered
| ERevFiltered
| ESorted
| ERevSorted
| EVisible
| ERevVisible
| ELineNum
| EDate
| EFlag
| ENumber
| EPayee
| EAccount
| EPostingDrCr
| EPostingCmdty
| EPostingQty
| ETotalDrCr
| ETotalCmdty
| ETotalQty
deriving (Show, Eq, Enum)
eTopRowCells :: TopRowCells ETopRowCells
eTopRowCells = TopRowCells
{ globalTransaction = EGlobalTransaction
, revGlobalTransaction = ERevGlobalTransaction
, globalPosting = EGlobalPosting
, revGlobalPosting = ERevGlobalPosting
, fileTransaction = EFileTransaction
, revFileTransaction = ERevFileTransaction
, filePosting = EFilePosting
, revFilePosting = ERevFilePosting
, filtered = EFiltered
, revFiltered = ERevFiltered
, sorted = ESorted
, revSorted = ERevSorted
, visible = EVisible
, revVisible = ERevVisible
, lineNum = ELineNum
, date = EDate
, flag = EFlag
, number = ENumber
, payee = EPayee
, account = EAccount
, postingDrCr = EPostingDrCr
, postingCmdty = EPostingCmdty
, postingQty = EPostingQty
, totalDrCr = ETotalDrCr
, totalCmdty = ETotalCmdty
, totalQty = ETotalQty }
instance Functor TopRowCells where
fmap f t = TopRowCells
{ globalTransaction = f (globalTransaction t)
, revGlobalTransaction = f (revGlobalTransaction t)
, globalPosting = f (globalPosting t)
, revGlobalPosting = f (revGlobalPosting t)
, fileTransaction = f (fileTransaction t)
, revFileTransaction = f (revFileTransaction t)
, filePosting = f (filePosting t)
, revFilePosting = f (revFilePosting t)
, filtered = f (filtered t)
, revFiltered = f (revFiltered t)
, sorted = f (sorted t)
, revSorted = f (revSorted t)
, visible = f (visible t)
, revVisible = f (revVisible t)
, lineNum = f (lineNum t)
, date = f (date t)
, flag = f (flag t)
, number = f (number t)
, payee = f (payee t)
, account = f (account t)
, postingDrCr = f (postingDrCr t)
, postingCmdty = f (postingCmdty t)
, postingQty = f (postingQty t)
, totalDrCr = f (totalDrCr t)
, totalCmdty = f (totalCmdty t)
, totalQty = f (totalQty t) }
instance Applicative TopRowCells where
pure a = TopRowCells
{ globalTransaction = a
, revGlobalTransaction = a
, globalPosting = a
, revGlobalPosting = a
, fileTransaction = a
, revFileTransaction = a
, filePosting = a
, revFilePosting = a
, filtered = a
, revFiltered = a
, sorted = a
, revSorted = a
, visible = a
, revVisible = a
, lineNum = a
, date = a
, flag = a
, number = a
, payee = a
, account = a
, postingDrCr = a
, postingCmdty = a
, postingQty = a
, totalDrCr = a
, totalCmdty = a
, totalQty = a }
ff <*> fa = TopRowCells
{ globalTransaction = globalTransaction ff (globalTransaction fa)
, revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa)
, globalPosting = globalPosting ff (globalPosting fa)
, revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa)
, fileTransaction = fileTransaction ff (fileTransaction fa)
, revFileTransaction = revFileTransaction ff (revFileTransaction fa)
, filePosting = filePosting ff (filePosting fa)
, revFilePosting = revFilePosting ff (revFilePosting fa)
, filtered = filtered ff (filtered fa)
, revFiltered = revFiltered ff (revFiltered fa)
, sorted = sorted ff (sorted fa)
, revSorted = revSorted ff (revSorted fa)
, visible = visible ff (visible fa)
, revVisible = revVisible ff (revVisible fa)
, lineNum = lineNum ff (lineNum fa)
, date = date ff (date fa)
, flag = flag ff (flag fa)
, number = number ff (number fa)
, payee = payee ff (payee fa)
, account = account ff (account fa)
, postingDrCr = postingDrCr ff (postingDrCr fa)
, postingCmdty = postingCmdty ff (postingCmdty fa)
, postingQty = postingQty ff (postingQty fa)
, totalDrCr = totalDrCr ff (totalDrCr fa)
, totalCmdty = totalCmdty ff (totalCmdty fa)
, totalQty = totalQty ff (totalQty fa) }
instance Fdbl.Foldable TopRowCells where
foldr f z o =
f (globalTransaction o)
(f (revGlobalTransaction o)
(f (globalPosting o)
(f (revGlobalPosting o)
(f (fileTransaction o)
(f (revFileTransaction o)
(f (filePosting o)
(f (revFilePosting o)
(f (filtered o)
(f (revFiltered o)
(f (sorted o)
(f (revSorted o)
(f (visible o)
(f (revVisible o)
(f (lineNum o)
(f (date o)
(f (flag o)
(f (number o)
(f (payee o)
(f (account o)
(f (postingDrCr o)
(f (postingCmdty o)
(f (postingQty o)
(f (totalDrCr o)
(f (totalCmdty o)
(f (totalQty o) z)))))))))))))))))))))))))
instance T.Traversable TopRowCells where
traverse f t =
TopRowCells
<$> f (globalTransaction t)
<*> f (revGlobalTransaction t)
<*> f (globalPosting t)
<*> f (revGlobalPosting t)
<*> f (fileTransaction t)
<*> f (revFileTransaction t)
<*> f (filePosting t)
<*> f (revFilePosting t)
<*> f (filtered t)
<*> f (revFiltered t)
<*> f (sorted t)
<*> f (revSorted t)
<*> f (visible t)
<*> f (revVisible t)
<*> f (lineNum t)
<*> f (date t)
<*> f (flag t)
<*> f (number t)
<*> f (payee t)
<*> f (account t)
<*> f (postingDrCr t)
<*> f (postingCmdty t)
<*> f (postingQty t)
<*> f (totalDrCr t)
<*> f (totalCmdty t)
<*> f (totalQty t)