-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.Format.Ledger.Write where
+import Control.Applicative ((<$>), (<*))
import Control.Arrow ((***))
import Data.Decimal (DecimalRaw(..))
import qualified Data.Char (isSpace)
import Data.Fixed (showFixed)
+import qualified Data.Foldable
import qualified Data.List
+import qualified Data.List.NonEmpty
import qualified Data.Map.Strict as Data.Map
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as TL
import qualified Data.Text as Text
-import Data.Text (Text)
import qualified Data.Time.Calendar as Time (toGregorian)
import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
-import qualified Text.PrettyPrint.Leijen.Text as P
-import Text.PrettyPrint.Leijen.Text (Doc, (<>))
+import qualified Hcompta.Lib.Leijen as W
+import Hcompta.Lib.Leijen (Doc, (<>))
import System.IO (Handle)
+import qualified Text.Parsec as R
+import Text.Parsec (Stream, ParsecT)
import qualified Hcompta.Model.Account as Account
import Hcompta.Model.Account (Account)
import Hcompta.Model.Date (Date)
-- import Hcompta.Format.Ledger.Journal as Journal
import qualified Hcompta.Format.Ledger.Read as Read
+import qualified Hcompta.Lib.Parsec as R
--- * Utilities
-
--- ** Rendering
-
-show :: Doc -> TL.Text
-show = P.displayT . P.renderPretty 1.0 maxBound
-
-showIO :: Handle -> Doc -> IO ()
-showIO handle = P.displayIO handle . P.renderPretty 1.0 maxBound
-
--- ** Combinators
-
--- | Return a 'Doc' from a strict 'Text'
-text :: Text -> Doc
-text = P.text . TL.fromStrict
-
--- | Return a 'Doc' concatenating converted values of a 'Map'
--- separated by a given 'Doc'
-map_concat
- :: Doc -> (a -> Doc)
- -> Data.Map.Map k a -> Doc
-map_concat sep f =
- snd . Data.Map.foldl
- (\(first, doc) x -> case first of
- True -> (False, f x)
- False -> (False, doc <> sep <> f x))
- (True, P.empty) -- NOTE: public API gives no way to test for P.empty
-- * Printing 'Account'
case type_ of
Posting.Type_Regular -> account_
Posting.Type_Virtual -> \acct ->
- P.char Read.posting_type_virtual_begin <> do
+ W.char Read.posting_type_virtual_begin <> do
account_ acct <> do
- P.char Read.posting_type_virtual_end
+ W.char Read.posting_type_virtual_end
Posting.Type_Virtual_Balanced -> \acct ->
- P.char Read.posting_type_virtual_balanced_begin <> do
+ W.char Read.posting_type_virtual_balanced_begin <> do
account_ acct <> do
- P.char Read.posting_type_virtual_balanced_end
+ W.char Read.posting_type_virtual_balanced_end
where
account_ :: Account -> Doc
account_ acct =
- P.align $ P.hcat $
- Data.List.intersperse
- (P.char Read.account_name_sep)
- (Data.List.map account_name acct)
+ W.align $ W.hcat $
+ Data.List.NonEmpty.toList $
+ Data.List.NonEmpty.intersperse
+ (W.bold $ W.yellow $ W.char Read.account_name_sep)
+ (Data.List.NonEmpty.map account_name acct)
account_name :: Account.Name -> Doc
-account_name = text
+account_name = W.strict_text
-- ** Mesuring 'Account'
account_length :: Posting.Type -> Account -> Int
account_length type_ acct =
- Data.List.foldl
+ Data.Foldable.foldl
(\acc -> (1 +) . (acc +) . Text.length)
- (if acct == [] then 0 else (- 1)) acct +
+ (- 1) acct +
case type_ of
Posting.Type_Regular -> 0
Posting.Type_Virtual -> 2
case unit_side of
Just Style.Side_Left ->
(unit unit_)
- <> (case unit_spaced of { Just True | unit_ /= "" -> P.space; _ -> P.empty })
- _ -> P.empty
+ <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
+ _ -> W.empty
<> quantity style qty
<> case unit_side of
(Just Style.Side_Right) ->
- (case unit_spaced of { Just True | unit_ /= "" -> P.space; _ -> P.empty })
+ (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
<> unit unit_
Nothing ->
- (case unit_spaced of { Just True | unit_ /= "" -> P.space; _ -> P.empty })
+ (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
<> unit unit_
- _ -> P.empty
+ _ -> W.empty
unit :: Unit -> Doc
-unit = text
+unit = W.yellow . W.strict_text
quantity :: Style -> Quantity -> Doc
quantity Style.Style
} qty = do
let Decimal e n = Quantity.round precision qty
let num = Prelude.show $ abs $ n
- let sign = text (if n < 0 then "-" else "")
+ let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
case e == 0 || precision == 0 of
- True -> sign <> (text $ Text.pack num)
+ True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
False -> do
let num_len = length num
let padded =
del_grouping_sep grouping_fractional $
['.', ',']
sign <> do
- P.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
- P.char (fromMaybe default_fractioning fractioning) <> do
- P.text (TL.pack $ maybe id group grouping_fractional frac)
+ W.bold $ W.blue $ do
+ W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
+ (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
+ W.text (TL.pack $ maybe id group grouping_fractional frac)
where
group :: Style.Grouping -> [Char] -> [Char]
group (Style.Grouping sep sizes_) =
Data.List.concat . reverse .
Data.List.map reverse . fst .
Data.List.foldl
- (flip (\digit -> \case
+ (flip (\digit -> \x -> case x of
([], sizes) -> ([[digit]], sizes)
(digits:groups, []) -> ((digit:digits):groups, [])
(digits:groups, curr_sizes@(size:sizes)) ->
else
Data.Map.foldr
(\n -> (3 +) . (+) (amount_length n))
- 0 amts
+ (-3) amts
quantity_length :: Style -> Quantity -> Int
quantity_length Style.Style
where
loop :: Int -> Int -> [Int] -> Int
loop pad len =
- \case
+ \x -> case x of
[] -> 0
sizes@[size] ->
let l = len - size in
(Time.LocalTime day tod)
tz@(Time.TimeZone tz_min _ tz_name)) = do
let (y, mo, d) = Time.toGregorian day
- (if y == 0 then P.empty else P.integer y <> P.char '/') <> do
+ (if y == 0 then W.empty else W.integer y <> sep '/') <> do
int2 mo <> do
- P.char '/' <> int2 d <> do
+ sep '/' <> int2 d <> do
(case tod of
- Time.TimeOfDay 0 0 0 -> P.empty
+ Time.TimeOfDay 0 0 0 -> W.empty
Time.TimeOfDay h m s ->
- P.space <> int2 h <> do
- P.char ':' <> int2 m <> do
+ W.space <> int2 h <> do
+ sep ':' <> int2 m <> do
(case s of
- 0 -> P.empty
- _ -> P.char ':' <> do
- (if s < 10 then P.char '0' else P.empty) <> do
- text $ Text.pack $ showFixed True s)) <> do
+ 0 -> W.empty
+ _ -> sep ':' <> do
+ (if s < 10 then W.char '0' else W.empty) <> do
+ W.strict_text $ Text.pack $ showFixed True s)) <> do
(case tz_min of
- 0 -> P.empty
- _ | tz_name /= "" -> P.space <> do text $ Text.pack tz_name
- _ -> P.space <> do text $ Text.pack $ Time.timeZoneOffsetString tz)
+ 0 -> W.empty
+ _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
+ _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
where
int2 :: Int -> Doc
- int2 i = if i < 10 then P.char '0' <> P.int i else P.int i
+ int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
+ sep :: Char -> Doc
+ sep = W.bold . W.dullblack . W.char
-- * Printing 'Comment'
comment :: Comment -> Doc
comment com =
- P.char Read.comment_begin
- <> (case Text.uncons com of
- Just (c, _) | not $ Data.Char.isSpace c -> P.space
- _ -> P.empty)
- <> text com
+ W.cyan $ do
+ W.char Read.comment_begin
+ <> (case Text.uncons com of
+ Just (c, _) | not $ Data.Char.isSpace c -> W.space
+ _ -> W.empty)
+ <> do W.if_color colorize (W.strict_text com)
+ where
+ colorize :: Doc
+ colorize =
+ case R.runParser (do
+ pre <- R.many $ R.try $ do
+ ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
+ sh <- R.space_horizontal
+ return (ns ++ [sh])
+ ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
+ () "" com of
+ Left _ -> W.strict_text com
+ Right doc -> doc
+ tags :: Stream s m Char => ParsecT s u m Doc
+ tags = do
+ x <- tag_
+ xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
+ return $ x <> xs
+ where
+ tag_sep :: Stream s m Char => ParsecT s u m Doc
+ tag_sep = do
+ s <- R.char Read.tag_sep
+ sh <- R.many R.space_horizontal
+ return $
+ do W.bold $ W.dullblack $ W.char s
+ <> do W.text $ TL.pack sh
+ tag_ :: Stream s m Char => ParsecT s u m Doc
+ tag_ = do
+ n <- Read.tag_name
+ s <- R.char Read.tag_value_sep
+ v <- Read.tag_value
+ return $
+ (W.yellow $ W.strict_text n)
+ <> (W.bold $ W.dullblack $ W.char s)
+ <> (W.red $ W.strict_text v)
comments :: Doc -> [Comment] -> Doc
comments prefix =
- P.align . P.hcat .
- Data.List.intersperse P.line .
+ W.hcat .
+ Data.List.intersperse W.line .
Data.List.map (\c -> prefix <> comment c)
-- * Printing 'Tag'
tag :: Tag -> Doc
-tag (n, v) = text n <> P.char Read.tag_value_sep <> text v
+tag (n, v) =
+ (W.dullyellow $ W.strict_text n)
+ <> W.char Read.tag_value_sep
+ <> (W.dullred $ W.strict_text v)
-- * Printing 'Posting'
, Posting.status=status_
-- , Posting.tags
} =
- P.char '\t' <> do
- P.align $ do
- status status_ <> do
- (case Data.Map.null amounts of
+ W.char '\t' <> do
+ status status_ <> do
+ case Data.Map.null amounts of
True -> account type_ acct
False ->
- P.fill (max_account_length + 2)
+ W.fill (max_account_length + 2)
(account type_ acct) <> do
- P.fill (max 0 (max_amount_length - amounts_length amounts)) P.empty <> do
- -- NOTE: AFAICS Text.PrettyPrint.Leijen gives no way
- -- to get the column size of a Doc
- -- before printing it, hence the call to amounts_length here again.
- map_concat
- (P.space <> P.char Read.amount_sep <> P.space)
- amount amounts)
+ W.fill (max 0
+ ( max_amount_length
+ - (fromIntegral $ amounts_length amounts) )) W.empty <> do
+ W.intercalate
+ (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
+ amount amounts
<> (case cmts of
- [] -> P.empty
- [c] -> P.space <> comment c
- _ -> P.line <> do comments (P.text "\t\t") cmts)
+ [] -> W.empty
+ [c] -> W.space <> comment c
+ _ -> W.line <> do comments (W.text "\t\t") cmts)
status :: Transaction.Status -> Doc
-status = \case
- True -> P.char '!'
- False -> P.empty
+status = \x -> case x of
+ True -> W.char '!'
+ False -> W.empty
-- ** Mesuring 'Posting'
-- , Transaction.tags
} = do
(case comments_before of
- [] -> P.empty
- _ -> comments (P.text "\t") comments_before <> P.line) <> do
- (P.hcat $
+ [] -> W.empty
+ _ -> comments (W.text "\t") comments_before <> W.line) <> do
+ (W.hcat $
Data.List.intersperse
- (P.char Read.date_sep)
+ (W.char Read.date_sep)
(Data.List.map date (first_date:dates))) <> do
(case status_ of
- True -> P.space <> status status_
- False -> P.empty) <> do
+ True -> W.space <> status status_
+ False -> W.empty) <> do
code code_ <> do
(case description of
- "" -> P.empty
- _ -> P.space <> text description) <> do
- P.line <> do
+ "" -> W.empty
+ _ -> W.space <> (W.dullmagenta $ W.strict_text description)) <> do
+ W.line <> do
(case comments_after of
- [] -> P.empty
- _ -> comments (P.text "\t") comments_after <> P.line) <> do
- P.vsep $ Data.List.map
+ [] -> W.empty
+ _ -> comments (W.text "\t") comments_after <> W.line) <> do
+ W.vsep $ Data.List.map
(\(type_, ps) ->
- map_concat P.line
- (map_concat P.line
- (P.vsep . Data.List.map
+ W.intercalate W.line
+ (W.intercalate W.line
+ (W.vsep . Data.List.map
(posting posting_lengths_ type_)))
(Posting.by_signs_and_account ps))
[ (Posting.Type_Regular, postings)
]
code :: Transaction.Code -> Doc
-code = \case
- "" -> P.empty
- t -> P.space <> P.char '(' <> text t <> P.char ')'
+code = \x -> case x of
+ "" -> W.empty
+ t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
-- ** Mesuring 'Transaction'
(Data.List.foldl (flip transaction_lengths))
nil_Transaction_Lengths
transactions
- snd $ Data.Map.foldl
- (Data.List.foldl (\(first, doc) t ->
- ( False
- , (if first then P.empty else doc <> P.line)
- <> transaction_with_lengths transaction_lengths_ t <> P.line
- )))
- (True, P.empty)
+ Data.Map.foldl
+ (Data.List.foldl (\doc t ->
+ (if W.is_empty doc then W.empty else doc <> W.line)
+ <> transaction_with_lengths transaction_lengths_ t <> W.line
+ ))
+ W.empty
transactions
+
+-- * Rendering
+
+show :: Bool -> Doc -> TL.Text
+show with_color = W.displayT . W.renderPretty with_color 1.0 maxBound
+
+put :: Bool -> Handle -> Doc -> IO ()
+put with_color handle = W.displayIO handle . W.renderPretty with_color 1.0 maxBound
sourcephile / git / comptalang.git / blobdiff