module Penny.Copper.Render where
import Control.Monad (guard)
import Control.Applicative ((<$>), (<|>), (<*>), pure)
import Data.List (intersperse)
import Data.Monoid ((<>))
import qualified Data.Text as X
import Data.Text (Text, cons, snoc)
import qualified Penny.Copper.Terminals as T
import qualified Data.Time as Time
import qualified Penny.Copper.Interface as I
import qualified Penny.Lincoln as L
import qualified Penny.Steel.Sums as S
txtWords :: [X.Text] -> X.Text
txtWords xs = case filter (not . X.null) xs of
[] -> X.empty
rs -> X.unwords rs
renMaybe :: Maybe a -> (a -> Maybe X.Text) -> Maybe X.Text
renMaybe mx f = case mx of
Nothing -> Just X.empty
Just a -> f a
isSubAcctLvl1 :: L.SubAccount -> Bool
isSubAcctLvl1 (L.SubAccount x) =
X.all T.lvl1AcctChar x && not (X.null x)
isAcctLvl1 :: L.Account -> Bool
isAcctLvl1 (L.Account ls) =
(not . null $ ls)
&& (all isSubAcctLvl1 ls)
quotedLvl1Acct :: L.Account -> Maybe Text
quotedLvl1Acct a@(L.Account ls) = do
guard (isAcctLvl1 a)
let txt = X.concat . intersperse (X.singleton ':')
. map L.unSubAccount $ ls
return $ '{' `X.cons` txt `X.snoc` '}'
isFirstSubAcctLvl2 :: L.SubAccount -> Bool
isFirstSubAcctLvl2 (L.SubAccount x) = case X.uncons x of
Nothing -> False
Just (c, r) -> T.letter c && (X.all T.lvl2AcctOtherChar r)
isOtherSubAcctLvl2 :: L.SubAccount -> Bool
isOtherSubAcctLvl2 (L.SubAccount x) =
(not . X.null $ x)
&& (X.all T.lvl2AcctOtherChar x)
isAcctLvl2 :: L.Account -> Bool
isAcctLvl2 (L.Account ls) = case ls of
[] -> False
x:xs -> isFirstSubAcctLvl2 x && all isOtherSubAcctLvl2 xs
lvl2Acct :: L.Account -> Maybe Text
lvl2Acct a@(L.Account ls) = do
guard $ isAcctLvl2 a
return . X.concat . intersperse (X.singleton ':')
. map L.unSubAccount $ ls
ledgerAcct :: L.Account -> Maybe Text
ledgerAcct a = lvl2Acct a <|> quotedLvl1Acct a
quotedLvl1Cmdty :: L.Commodity -> Maybe Text
quotedLvl1Cmdty (L.Commodity c) =
if X.all T.lvl1CmdtyChar c
then Just $ '"' `cons` c `snoc` '"'
else Nothing
lvl2Cmdty :: L.Commodity -> Maybe Text
lvl2Cmdty (L.Commodity c) = do
(f, rs) <- X.uncons c
guard $ T.lvl2CmdtyFirstChar f
guard . X.all T.lvl2CmdtyOtherChar $ rs
return c
lvl3Cmdty :: L.Commodity -> Maybe Text
lvl3Cmdty (L.Commodity c) =
if (not . X.null $ c) && (X.all T.lvl3CmdtyChar c)
then return c
else Nothing
quoteQtyRep :: L.QtyRep -> (Text, Text)
quoteQtyRep q = case q of
L.QNoGrouping _ r -> case r of
L.Period -> ("", "")
L.Comma -> ("[", "]")
L.QGrouped ei -> case ei of
Left wf -> if hasSpace wf then ("{", "}") else ("", "")
Right _ -> ("[", "]")
qtyRep :: L.QtyRep -> Text
qtyRep q = b <> L.showQtyRep q <> e
where
(b, e) = quoteQtyRep q
hasSpace :: L.WholeOrFrac (L.GroupedDigits L.PeriodGrp) -> Bool
hasSpace (L.WholeOrFrac ei) = case ei of
Left w -> grpHasSpace . L.unWholeOnly $ w
Right wf -> grpHasSpace (L.whole wf) || grpHasSpace (L.frac wf)
where
grpHasSpace grp = L.PGSpace `elem` (map fst . L.dsNextParts $ grp)
amount
:: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
-> Maybe L.Side
-> Maybe L.SpaceBetween
-> Either (L.Amount L.QtyRep) (L.Amount L.Qty)
-> Maybe X.Text
amount mayFmt maySd maySb ei = do
(q, c) <- case ei of
Left a -> return (qtyRep . L.qty $ a, L.commodity a)
Right a -> case mayFmt of
Nothing -> Nothing
Just f -> return ( qtyRep . L.qtyToRep (f a) . L.qty $ a,
L.commodity a)
sd <- maySd
sb <- maySb
let ws = case sb of
L.SpaceBetween -> X.singleton ' '
L.NoSpaceBetween -> X.empty
(l, r) <- case sd of
L.CommodityOnLeft -> do
cx <- lvl3Cmdty c <|> quotedLvl1Cmdty c
return (cx, q)
L.CommodityOnRight -> do
cx <- lvl2Cmdty c <|> quotedLvl1Cmdty c
return (q, cx)
return $ X.concat [l, ws, r]
comment :: I.Comment -> Maybe X.Text
comment (I.Comment x) =
if (not . X.all T.nonNewline $ x)
then Nothing
else Just $ '#' `cons` x `snoc` '\n'
dateTime :: L.DateTime -> X.Text
dateTime (L.DateTime d h m s z) = X.append xd xr
where
(iYr, iMo, iDy) = Time.toGregorian d
xr = hoursMinsSecsZone h m s z
dash = X.singleton '-'
xd = X.concat [ showX iYr, dash, pad2 . showX $ iMo, dash,
pad2 . showX $ iDy ]
pad2 :: X.Text -> X.Text
pad2 = X.justifyRight 2 '0'
pad4 :: X.Text -> X.Text
pad4 = X.justifyRight 4 '0'
showX :: Show a => a -> X.Text
showX = X.pack . show
hoursMinsSecsZone
:: L.Hours -> L.Minutes -> L.Seconds -> L.TimeZoneOffset -> X.Text
hoursMinsSecsZone h m s z =
if z == L.noOffset && (h, m, s) == L.midnight
then X.empty
else let xhms = X.concat [xh, colon, xm, xs]
xh = pad2 . showX . L.unHours $ h
xm = pad2 . showX . L.unMinutes $ m
xs = let secs = L.unSeconds s
in if secs == 0
then X.empty
else ':' `X.cons` (pad2 . showX $ secs)
off = L.offsetToMins z
sign = X.singleton $ if off < 0 then '-' else '+'
padded = pad4 . showX . abs $ off
xz = if off == 0
then X.empty
else ' ' `X.cons` sign `X.append` padded
colon = X.singleton ':'
in ' ' `X.cons` xhms `X.append` xz
entry
:: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
-> Maybe L.Side
-> Maybe L.SpaceBetween
-> Either (L.Entry L.QtyRep) (L.Entry L.Qty)
-> Maybe X.Text
entry mayFmt sd sb ei = do
amt <- amount mayFmt sd sb
(either (Left . L.amount) (Right . L.amount) ei)
let dc = either L.drCr L.drCr ei
dcTxt = X.pack $ case dc of
L.Debit -> "<"
L.Credit -> ">"
return $ X.append (X.snoc dcTxt ' ') amt
flag :: L.Flag -> Maybe X.Text
flag (L.Flag fl) =
if X.all T.flagChar fl
then Just $ '[' `cons` fl `snoc` ']'
else Nothing
postingMemoLine
:: Int
-> X.Text
-> Maybe X.Text
postingMemoLine p x =
if X.all T.nonNewline x
then let trailing = X.replicate p (X.singleton ' ')
ls = [X.singleton '\'', x, X.singleton '\n', trailing]
in Just $ X.concat ls
else Nothing
postingMemo :: Bool -> L.Memo -> Maybe X.Text
postingMemo iLast (L.Memo ls) =
if null ls
then Nothing
else let bs = replicate (length ls 1) 8 ++ [if iLast then 4 else 0]
in fmap X.concat . sequence $ zipWith postingMemoLine bs ls
transactionMemoLine :: X.Text -> Maybe X.Text
transactionMemoLine x =
if X.all T.nonNewline x
then Just $ ';' `cons` x `snoc` '\n'
else Nothing
transactionMemo :: L.Memo -> Maybe X.Text
transactionMemo (L.Memo ls) =
if null ls
then Nothing
else fmap X.concat . mapM transactionMemoLine $ ls
number :: L.Number -> Maybe Text
number (L.Number t) =
if X.all T.numberChar t
then Just $ '(' `cons` t `snoc` ')'
else Nothing
quotedLvl1Payee :: L.Payee -> Maybe Text
quotedLvl1Payee (L.Payee p) = do
guard (X.all T.quotedPayeeChar p)
return $ '~' `X.cons` p `X.snoc` '~'
lvl2Payee :: L.Payee -> Maybe Text
lvl2Payee (L.Payee p) = do
(c1, cs) <- X.uncons p
guard (T.letter c1)
guard (X.all T.nonNewline cs)
return p
payee :: L.Payee -> Maybe Text
payee p = lvl2Payee p <|> quotedLvl1Payee p
price
:: L.PricePoint
-> Maybe X.Text
price pp = let
dateTxt = dateTime (L.dateTime pp)
(L.From from) = L.from . L.price $ pp
(L.To to) = L.to . L.price $ pp
(L.CountPerUnit q) = L.countPerUnit . L.price $ pp
mayFromTxt = lvl3Cmdty from <|> quotedLvl1Cmdty from
in do
amtTxt <- amount Nothing (L.ppSide pp) (L.ppSpaceBetween pp)
(Left (L.Amount q to))
fromTxt <- mayFromTxt
return $
(X.intercalate (X.singleton ' ')
[X.singleton '@', dateTxt, fromTxt, amtTxt])
`snoc` '\n'
tag :: L.Tag -> Maybe X.Text
tag (L.Tag t) =
if X.all T.tagChar t
then Just $ X.cons '*' t
else Nothing
tags :: L.Tags -> Maybe X.Text
tags (L.Tags ts) =
X.intercalate (X.singleton ' ')
<$> mapM tag ts
topLine :: L.TopLineCore -> Maybe X.Text
topLine tl =
f
<$> pure (dateTime (L.tDateTime tl))
<*> renMaybe (L.tMemo tl) transactionMemo
<*> renMaybe (L.tFlag tl) flag
<*> renMaybe (L.tNumber tl) number
<*> renMaybe (L.tPayee tl) payee
where
f dtX meX flX nuX paX =
X.concat [ meX, txtWords [dtX, flX, nuX, paX],
X.singleton '\n',
X.replicate 4 (X.singleton ' ') ]
posting
:: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
-> Bool
-> L.Ent L.PostingCore
-> Maybe X.Text
posting maySpec pad ent = do
let p = L.meta ent
fl <- renMaybe (L.pFlag p) flag
nu <- renMaybe (L.pNumber p) number
pa <- renMaybe (L.pPayee p) quotedLvl1Payee
ac <- ledgerAcct (L.pAccount p)
ta <- tags (L.pTags p)
me <- renMaybe (L.pMemo p) (postingMemo pad)
let mayEn = if L.inferred ent then Nothing else Just $ L.entry ent
en <- renMaybe mayEn (entry maySpec (L.pSide p) (L.pSpaceBetween p))
return $ formatter pad fl nu pa ac ta en me
formatter
:: Bool
-> X.Text
-> X.Text
-> X.Text
-> X.Text
-> X.Text
-> X.Text
-> X.Text
-> X.Text
formatter pad fl nu pa ac ta en me = let
colBnoPad = txtWords [fl, nu, pa, ac, ta]
colD = en
colB = if X.null en
then colBnoPad
else X.justifyLeft 50 ' ' colBnoPad
colC = if X.null en
then X.empty
else X.pack (replicate 2 ' ')
rtn = '\n' `X.cons` trailingWhite
trailingWhite = case (X.null me, pad) of
(True, False) -> X.empty
(True, True) -> X.replicate 4 (X.singleton ' ')
(False, _) -> X.replicate 8 (X.singleton ' ')
in X.concat [colB, colC, colD, rtn, me]
transaction
:: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
-> (L.TopLineCore, L.Ents L.PostingCore)
-> Maybe X.Text
transaction mayFmt txn = do
tlX <- topLine . fst $ txn
let (p1, p2, ps) = L.tupleEnts . snd $ txn
p1X <- posting mayFmt True p1
p2X <- posting mayFmt (not . null $ ps) p2
psX <- if null ps
then return X.empty
else let bs = replicate (length ps 1) True ++ [False]
in fmap X.concat . sequence
$ zipWith (posting mayFmt) bs ps
return $ X.concat [tlX, p1X, p2X, psX]
item
:: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
-> S.S4 (L.TopLineCore, L.Ents L.PostingCore)
L.PricePoint
I.Comment
I.BlankLine
-> Maybe X.Text
item mayFmt =
S.caseS4 (transaction mayFmt)
price
comment
(const (Just (X.pack "\n")))