module Penny.Cabin.Posts.Allocated (
payeeAndAcct
, AllocatedOpts(..)
, Fields(..)
, SubAccountLength(..)
, Alloc
, alloc
, unAlloc
) where
import Control.Applicative(Applicative((<*>), pure), (<$>))
import Control.Arrow (second)
import Data.Maybe (catMaybes, isJust)
import Data.List (intersperse)
import qualified Data.Foldable as Fdbl
import qualified Data.Sequence as Seq
import qualified Data.Traversable as T
import qualified Data.Text as X
import qualified Penny.Steel.Chunk as C
import qualified Penny.Cabin.Row as R
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.Cabin.Scheme as E
import qualified Penny.Cabin.TextFormat as TF
import qualified Penny.Lincoln as L
import qualified Penny.Lincoln.Bits.Qty as Qty
import qualified Penny.Lincoln.Queries as Q
import qualified Penny.Lincoln.HasText as HT
data Fields a = Fields {
payee :: a
, account :: a
} deriving (Eq, Show)
newtype SubAccountLength =
SubAccountLength { unSubAccountLength :: Int }
deriving Show
newtype Alloc = Alloc { unAlloc :: Int }
deriving Show
alloc :: Int -> Alloc
alloc i =
if i < 1
then error $ "allocations must be greater than zero."
++ " supplied allocation: " ++ show i
else Alloc i
data AllocatedOpts = AllocatedOpts
{ fields :: Fields Bool
, subAccountLength :: SubAccountLength
, allocations :: Fields Alloc
, spacers :: S.Spacers Int
, growerWidths :: G.Fields (Maybe Int)
, reportWidth :: Ty.ReportWidth
}
payeeAndAcct
:: AllocatedOpts
-> [Box]
-> Fields (Maybe ([R.ColumnSpec], Int))
payeeAndAcct ao bs =
let allBuilders =
T.traverse (builders (subAccountLength ao)) bs
availWidth = availableWidthForAllocs (growerWidths ao)
(spacers ao) (fields ao) (reportWidth ao)
finals = divideAvailableWidth availWidth (fields ao)
(allocations ao)
( fmap (safeMaximum (Request 0))
. fmap (fmap fst) $ allBuilders)
in fmap (fmap (second unFinal))
. buildSpecs finals
. fmap (fmap snd)
$ allBuilders
safeMaximum :: Ord a => a -> [a] -> a
safeMaximum d ls = case ls of
[] -> d
xs -> maximum xs
payeeAndAccountSpacerWidth
:: Fields Bool
-> S.Spacers Int
-> Int
payeeAndAccountSpacerWidth flds ss = pye + act
where
pye = if payee flds then abs (S.payee ss) else 0
act = if account flds then abs (S.account ss) else 0
newtype AvailableWidth = AvailableWidth Int
deriving (Eq, Ord, Show)
availableWidthForAllocs
:: G.Fields (Maybe Int)
-> S.Spacers Int
-> Fields Bool
-> Ty.ReportWidth
-> AvailableWidth
availableWidthForAllocs growers ss flds (Ty.ReportWidth w) =
AvailableWidth $ max 0 diff
where
tot = sumGrowersAndSpacers growers ss
+ payeeAndAccountSpacerWidth flds ss
diff = w tot
sumSpacers ::
G.Fields (Maybe a)
-> S.Spacers Int
-> Int
sumSpacers fs =
sum
. map fst
. appearingSpacers
. catMaybes
. Fdbl.toList
. fmap toWidth
. pairedWithSpacers fs
toWidth :: (Maybe a, Maybe Int, t) -> Maybe (Int, t)
toWidth (maybeShowing, maybeWidth, tag) =
if isJust maybeShowing
then case maybeWidth of
Just w -> Just (w, tag)
Nothing -> Just (0, tag)
else Nothing
appearingSpacers :: [(Int, G.EFields)] -> [(Int, G.EFields)]
appearingSpacers ss = case ss of
[] -> []
l -> case snd $ last l of
G.ETotalQty -> l
t -> if t > G.ENumber
then init l
else l
pairedWithSpacers ::
G.Fields a
-> S.Spacers b
-> G.Fields (a, Maybe b, G.EFields)
pairedWithSpacers f s =
(\(a, b) c -> (a, b, c))
<$> G.pairWithSpacer f s
<*> G.eFields
sumGrowersAndSpacers ::
G.Fields (Maybe Int)
-> S.Spacers Int
-> Int
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
newtype Request = Request { unRequest :: Int }
deriving (Eq, Ord, Show)
newtype Final = Final { unFinal :: Int }
deriving (Eq, Ord, Show)
buildSpecs
:: Fields (Maybe Final)
-> Fields ([Final -> R.ColumnSpec])
-> Fields (Maybe ([R.ColumnSpec], Final))
buildSpecs finals bs = f <$> finals <*> bs
where
f mayFinal gs = case mayFinal of
Nothing -> Nothing
Just fin -> Just ((gs <*> pure fin), fin)
divideAvailableWidth
:: AvailableWidth
-> Fields Bool
-> Fields Alloc
-> Fields Request
-> Fields (Maybe Final)
divideAvailableWidth (AvailableWidth aw) appear allocs rws = Fields pye act
where
minFinal i1 i2 =
let m = min i1 i2
in if m > 0 then Just . Final $ m else Nothing
pairAtLeast i1 i2 = (atLeast i1, atLeast i2)
where atLeast i = if i > 0 then Just . Final $ i else Nothing
reqP = unRequest . payee $ rws
reqA = unRequest . account $ rws
(pye, act) = case (payee appear, account appear) of
(False, False) -> (Nothing, Nothing)
(True, False) -> (minFinal reqP aw, Nothing)
(False, True) -> (Nothing, minFinal reqA aw)
(True, True) ->
let votes = [unAlloc . payee $ allocs, unAlloc . account $ allocs]
allocRslt = Qty.largestRemainderMethod (fromIntegral aw)
(map fromIntegral votes)
(allocP, allocA) = case allocRslt of
x:y:[] -> (fromIntegral x, fromIntegral y)
_ -> error "divideAvailableWidth error"
in case (allocP > reqP, allocA > reqA) of
(True, True) -> pairAtLeast reqP reqA
(True, False) ->
pairAtLeast reqP $ (min (allocA + (allocP reqP))) reqA
(False, True) ->
pairAtLeast (min reqP (allocP + (allocA reqA))) reqA
(False, False) -> pairAtLeast allocP allocA
builders
:: SubAccountLength
-> Box
-> Fields (Request, Final -> R.ColumnSpec)
builders sl b = Fields (buildPayee b) (buildAcct sl b)
buildPayee
:: Box
-> (Request, Final -> R.ColumnSpec)
buildPayee i = (maxW, mkSpec)
where
pb = L.boxPostFam i
eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i
j = R.LeftJustify
ps = (E.Other, eo)
mayPye = Q.payee pb
maxW = Request $ maybe 0 (X.length . HT.text) mayPye
mkSpec (Final w) = R.ColumnSpec j (C.Width w) ps sq
where
sq = case mayPye of
Nothing -> []
Just pye ->
let wrapped =
Fdbl.toList
. TF.unLines
. TF.wordWrap w
. TF.txtWords
. HT.text
$ pye
toBit (TF.Words seqTxts) =
E.PreChunk E.Other eo
. X.unwords
. Fdbl.toList
$ seqTxts
in fmap toBit wrapped
buildAcct ::
SubAccountLength
-> Box
-> (Request, Final -> R.ColumnSpec)
buildAcct sl i = (maxW, mkSpec)
where
pb = L.boxPostFam i
eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i
ps = (E.Other, eo)
aList = L.unAccount . Q.account $ pb
maxW = Request
$ (sum . map (X.length . L.unSubAccount) $ aList)
+ max 0 (length aList 1)
mkSpec (Final aw) = R.ColumnSpec R.LeftJustify (C.Width aw) ps sq
where
target = TF.Target aw
shortest = TF.Shortest . unSubAccountLength $ sl
ws = TF.Words . Seq.fromList . map L.unSubAccount $ aList
(TF.Words shortened) = TF.shorten shortest target ws
sq = [ E.PreChunk E.Other eo
. X.concat
. intersperse (X.singleton ':')
. Fdbl.toList
$ shortened ]
instance Functor Fields where
fmap f i = Fields {
payee = f (payee i)
, account = f (account i) }
instance Applicative Fields where
pure a = Fields a a
ff <*> fa = Fields {
payee = payee ff (payee fa)
, account = account ff (account fa) }
instance Fdbl.Foldable Fields where
foldr f z flds =
f (payee flds) (f (account flds) z)
instance T.Traversable Fields where
traverse f flds =
Fields <$> f (payee flds) <*> f (account flds)