-- | Calculates cells that "grow to fit." These cells grow to fit the
-- 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 (
  growCells, Fields(..), grownWidth,
  eFields, EFields(..), pairWithSpacer) where

import Control.Applicative((<$>), Applicative(pure, (<*>)))
import qualified Data.Foldable as Fdbl
import Data.Map (elems, assocs)
import qualified Data.Semigroup as Semi
import Data.Semigroup ((<>))
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.Posts.Fields as F
import qualified Penny.Cabin.Posts.Meta as M
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 

-- | Grows the cells that will be GrowToFit cells in the report. First
-- this function fills in all visible cells with text, but leaves the
-- width undetermined. Then it determines the widest line in each
-- column. Finally it adjusts each cell in the column so that it is
-- that maximum width.
--
-- Returns a list of rows, and a Fields holding the width of each
-- cell. Each of these widths will be at least 1; fields that were in
-- the report but that ended up having no width are changed to
-- Nothing.
growCells ::
  Options.T
  -> [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
      in if w > 0 then Just (cs', w) else Nothing
    | otherwise = Nothing
  wanted = growingFields o

widestLine :: PreSpec -> Int
widestLine (PreSpec _ _ bs) =
  maximum . map (R.unWidth . C.chunkWidth) $ bs

data PreSpec = PreSpec {
  _justification :: R.Justification
  , _padSpec :: C.TextSpec
  , _bits :: [C.Chunk] }


-- | Given a PreSpec and a width, create a ColumnSpec of the right
-- size.
sizer :: R.Width -> PreSpec -> R.ColumnSpec
sizer w (PreSpec j ts bs) = R.ColumnSpec j w ts bs

-- | 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
      j = R.LeftJustify
      bit = C.chunk ts t
  in PreSpec j ts [bit]

growers :: Fields (Options.T -> 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 }

-- | 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
  where
    t = case f (L.boxPostFam b) of
      Nothing -> X.empty
      Just i -> X.pack . show $ i

serialCell ::
  (M.PostMeta -> Int)
  -> Options.T -> Box -> PreSpec
serialCell f os b = oneLine t os b
  where
    t = pack . show . f . L.boxMeta $ b

getGlobalTransaction :: Options.T -> Box -> PreSpec
getGlobalTransaction =
  serialCellMaybe (fmap (L.forward . L.unGlobalTransaction)
                   . Q.globalTransaction)

getRevGlobalTransaction :: Options.T -> Box -> PreSpec
getRevGlobalTransaction =
  serialCellMaybe (fmap (L.backward . L.unGlobalTransaction)
                   . Q.globalTransaction)

getGlobalPosting :: Options.T -> Box -> PreSpec
getGlobalPosting =
  serialCellMaybe (fmap (L.forward . L.unGlobalPosting)
                   . Q.globalPosting)

getRevGlobalPosting :: Options.T -> Box -> PreSpec
getRevGlobalPosting =
  serialCellMaybe (fmap (L.backward . L.unGlobalPosting)
                   . Q.globalPosting)

getFileTransaction :: Options.T -> Box -> PreSpec
getFileTransaction =
  serialCellMaybe (fmap (L.forward . L.unFileTransaction)
                   . Q.fileTransaction)

getRevFileTransaction :: Options.T -> Box -> PreSpec
getRevFileTransaction =
  serialCellMaybe (fmap (L.backward . L.unFileTransaction)
                   . Q.fileTransaction)

getFilePosting :: Options.T -> Box -> PreSpec
getFilePosting =
  serialCellMaybe (fmap (L.forward . L.unFilePosting)
                   . Q.filePosting)

getRevFilePosting :: Options.T -> Box -> PreSpec
getRevFilePosting =
  serialCellMaybe (fmap (L.backward . L.unFilePosting)
                   . Q.filePosting)

getSorted :: Options.T -> Box -> PreSpec
getSorted =
  serialCell (L.forward . Ly.unSortedNum . M.sortedNum)

getRevSorted :: Options.T -> Box -> PreSpec
getRevSorted =
  serialCell (L.backward . Ly.unSortedNum . M.sortedNum)

getFiltered :: Options.T -> Box -> PreSpec
getFiltered =
  serialCell (L.forward . Ly.unFilteredNum . M.filteredNum)

getRevFiltered :: Options.T -> Box -> PreSpec
getRevFiltered =
  serialCell (L.backward . Ly.unFilteredNum . M.filteredNum)

getVisible :: Options.T -> Box -> PreSpec
getVisible =
  serialCell (L.forward . M.unVisibleNum . M.visibleNum)

getRevVisible :: Options.T -> Box -> PreSpec
getRevVisible =
  serialCell (L.backward . M.unVisibleNum . M.visibleNum)


getLineNum :: Options.T -> Box -> PreSpec
getLineNum os b = oneLine t os 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

getFlag :: Options.T -> Box -> PreSpec
getFlag os i = oneLine t os 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
  t = maybe empty L.text (Q.number . L.boxPostFam $ i)

dcTxt :: L.DrCr -> Text
dcTxt L.Debit = pack "Dr"
dcTxt L.Credit = pack "Cr"

-- | 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
  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

getPostingDrCr :: Options.T -> Box -> PreSpec
getPostingDrCr os i = coloredPostingCell t os i where
  t = dcTxt . Q.drCr . L.boxPostFam $ i

getPostingCmdty :: Options.T -> Box -> PreSpec
getPostingCmdty os i = coloredPostingCell t os 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

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
  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
  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
  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 }

-- | All growing fields, as an ADT.
data EFields =
  EGlobalTransaction
  | ERevGlobalTransaction
  | EGlobalPosting
  | ERevGlobalPosting
  | EFileTransaction
  | ERevFileTransaction
  | EFilePosting
  | ERevFilePosting
  | EFiltered
  | ERevFiltered
  | ESorted
  | ERevSorted
  | EVisible
  | ERevVisible
  | ELineNum
  | EDate
  | EFlag
  | ENumber
  | EPostingDrCr
  | EPostingCmdty
  | EPostingQty
  | ETotalDrCr
  | ETotalCmdty
  | ETotalQty
  deriving (Show, Eq, Ord, Enum)

-- | Returns a Fields where each record has its corresponding EField.
eFields :: Fields EFields
eFields = Fields {
  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
  , postingDrCr          = EPostingDrCr
  , postingCmdty         = EPostingCmdty
  , postingQty           = EPostingQty
  , totalDrCr            = ETotalDrCr
  , totalCmdty           = ETotalCmdty
  , totalQty             = ETotalQty }

-- | All growing fields.
data Fields a = Fields {
  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
    -- ^ The line number from the posting's metadata
  , date                 :: a
  , flag                 :: a
  , number               :: a
  , postingDrCr          :: a
  , postingCmdty         :: a
  , postingQty           :: a
  , totalDrCr            :: a
  , totalCmdty           :: a
  , totalQty             :: a }
  deriving (Show, Eq)

instance Fdbl.Foldable Fields where
  foldr f z i =
    f (globalTransaction i)
    (f (revGlobalTransaction i)
     (f (globalPosting i)
      (f (revGlobalPosting i)
       (f (fileTransaction i)
        (f (revFileTransaction i)
         (f (filePosting i)
          (f (revFilePosting i)
           (f (filtered i)
            (f (revFiltered i)
             (f (sorted i)
              (f (revSorted i)
               (f (visible i)
                (f (revVisible i)
                 (f (lineNum i)
                  (f (date i)
                   (f (flag i)
                    (f (number i)
                     (f (postingDrCr i)
                      (f (postingCmdty i)
                       (f (postingQty i)
                        (f (totalDrCr i)
                         (f (totalCmdty i)
                          (f (totalQty i) z)))))))))))))))))))))))

instance Functor Fields where
  fmap f i = Fields {
    globalTransaction      = f (globalTransaction    i)
    , revGlobalTransaction = f (revGlobalTransaction i)
    , globalPosting        = f (globalPosting        i)
    , revGlobalPosting     = f (revGlobalPosting     i)
    , fileTransaction      = f (fileTransaction      i)
    , revFileTransaction   = f (revFileTransaction   i)
    , filePosting          = f (filePosting          i)
    , revFilePosting       = f (revFilePosting       i)
    , filtered             = f (filtered             i)
    , revFiltered          = f (revFiltered          i)
    , sorted               = f (sorted               i)
    , revSorted            = f (revSorted            i)
    , visible              = f (visible              i)
    , revVisible           = f (revVisible           i)
    , lineNum              = f (lineNum              i)
    , date                 = f (date                 i)
    , flag                 = f (flag                 i)
    , number               = f (number               i)
    , postingDrCr          = f (postingDrCr          i)
    , postingCmdty         = f (postingCmdty         i)
    , postingQty           = f (postingQty           i)
    , totalDrCr            = f (totalDrCr            i)
    , totalCmdty           = f (totalCmdty           i)
    , totalQty             = f (totalQty             i) }

instance Applicative Fields where
  pure a = Fields {
    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
    , postingDrCr          = a
    , postingCmdty         = a
    , postingQty           = a
    , totalDrCr            = a
    , totalCmdty           = a
    , totalQty             = a }

  fl <*> fa = Fields {
    globalTransaction      = globalTransaction    fl (globalTransaction    fa)
    , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa)
    , globalPosting        = globalPosting        fl (globalPosting        fa)
    , revGlobalPosting     = revGlobalPosting     fl (revGlobalPosting     fa)
    , fileTransaction      = fileTransaction      fl (fileTransaction      fa)
    , revFileTransaction   = revFileTransaction   fl (revFileTransaction   fa)
    , filePosting          = filePosting          fl (filePosting          fa)
    , revFilePosting       = revFilePosting       fl (revFilePosting       fa)
    , filtered             = filtered             fl (filtered             fa)
    , revFiltered          = revFiltered          fl (revFiltered          fa)
    , sorted               = sorted               fl (sorted               fa)
    , revSorted            = revSorted            fl (revSorted            fa)
    , visible              = visible              fl (visible              fa)
    , revVisible           = revVisible           fl (revVisible           fa)
    , lineNum              = lineNum              fl (lineNum              fa)
    , date                 = date                 fl (date                 fa)
    , flag                 = flag                 fl (flag                 fa)
    , number               = number               fl (number               fa)
    , postingDrCr          = postingDrCr          fl (postingDrCr          fa)
    , postingCmdty         = postingCmdty         fl (postingCmdty         fa)
    , postingQty           = postingQty           fl (postingQty           fa)
    , totalDrCr            = totalDrCr            fl (totalDrCr            fa)
    , totalCmdty           = totalCmdty           fl (totalCmdty           fa)
    , totalQty             = totalQty             fl (totalQty             fa) }

-- | 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 f s = Fields {
  globalTransaction      = (globalTransaction    f, Just (S.globalTransaction    s))
  , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s))
  , globalPosting        = (globalPosting        f, Just (S.globalPosting        s))
  , revGlobalPosting     = (revGlobalPosting     f, Just (S.revGlobalPosting     s))
  , fileTransaction      = (fileTransaction      f, Just (S.fileTransaction      s))
  , revFileTransaction   = (revFileTransaction   f, Just (S.revFileTransaction   s))
  , filePosting          = (filePosting          f, Just (S.filePosting          s))
  , revFilePosting       = (revFilePosting       f, Just (S.revFilePosting       s))
  , filtered             = (filtered             f, Just (S.filtered             s))
  , revFiltered          = (revFiltered          f, Just (S.revFiltered          s))
  , sorted               = (sorted               f, Just (S.sorted               s))
  , revSorted            = (revSorted            f, Just (S.revSorted            s))
  , visible              = (visible              f, Just (S.visible              s))
  , revVisible           = (revVisible           f, Just (S.revVisible           s))
  , lineNum              = (lineNum              f, Just (S.lineNum              s))
  , date                 = (date                 f, Just (S.date                 s))
  , flag                 = (flag                 f, Just (S.flag                 s))
  , number               = (number               f, Just (S.number               s))
  , postingDrCr          = (postingDrCr          f, Just (S.postingDrCr          s))
  , postingCmdty         = (postingCmdty         f, Just (S.postingCmdty         s))
  , postingQty           = (postingQty           f, Just (S.postingQty           s))
  , totalDrCr            = (totalDrCr            f, Just (S.totalDrCr            s))
  , totalCmdty           = (totalCmdty           f, Just (S.totalCmdty           s))
  , totalQty             = (totalQty             f, Nothing                        ) }

-- | Reduces a set of Fields to a single value.
reduce :: Semi.Semigroup s => Fields s -> s
reduce f =
  globalTransaction       f
  <> revGlobalTransaction f
  <> globalPosting        f
  <> revGlobalPosting     f
  <> fileTransaction      f
  <> revFileTransaction   f
  <> filePosting          f
  <> revFilePosting       f
  <> filtered             f
  <> revFiltered          f
  <> sorted               f
  <> revSorted            f
  <> visible              f
  <> revVisible           f
  <> lineNum              f
  <> date                 f
  <> flag                 f
  <> number               f
  <> postingDrCr          f
  <> postingCmdty         f
  <> postingQty           f
  <> totalDrCr            f
  <> totalCmdty           f
  <> totalQty             f

-- | Compute the width of all Grown cells, including any applicable
-- spacer cells.
grownWidth ::
  Fields (Maybe Int)
  -> Spacers.T Int
  -> Int
grownWidth fs ss =
  Semi.getSum
  . reduce
  . fmap Semi.Sum
  . fmap fieldWidth
  $ pairWithSpacer fs ss

-- | Compute the field width of a single field and its spacer. The
-- first element of the tuple is the field width, if present; the
-- second element of the tuple is the width of the spacer. If there is
-- no field, returns 0.
fieldWidth :: (Maybe Int, Maybe Int) -> Int
fieldWidth (m1, m2) = case m1 of
  Nothing -> 0
  Just i1 -> case m2 of
    Just i2 -> if i2 > 0 then i1 + i2 else i1
    Nothing -> i1