Polissage : CLI.Command.Balance : is_worth.
[comptalang.git] / lib / Hcompta / Format / Ledger / Write.hs
index a216d2abb2d9b8c43efda94148e50e34a6731715..b1ff19ae42b356e5e81ef7a691328b6bc3b6ecd5 100644 (file)
@@ -1,39 +1,31 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Hcompta.Format.Ledger.Write where
 
-import           Control.Applicative ((<$>), (<*))
-import           Control.Arrow ((***))
-import           Data.Decimal (DecimalRaw(..))
+-- import           Control.Applicative ((<$>), (<*))
 import qualified Data.Char (isSpace)
-import           Data.Fixed (showFixed)
+import qualified Data.Functor.Compose
 import qualified Data.Foldable
+-- import           Data.Foldable (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 qualified Data.Time.Calendar  as Time (toGregorian)
-import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
 import qualified Hcompta.Lib.Leijen as W
 import           Hcompta.Lib.Leijen (Doc, (<>))
 import           System.IO (Handle)
 import qualified Text.Parsec as R hiding (satisfy, char)
 import           Text.Parsec (Stream, ParsecT)
 
-import qualified Hcompta.Model.Account as Account
-import           Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import           Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Amount.Quantity as Quantity
-import           Hcompta.Model.Amount.Quantity (Quantity)
-import qualified Hcompta.Model.Amount.Style as Style
-import           Hcompta.Model.Amount.Style (Style)
-import qualified Hcompta.Model.Amount.Unit as Unit
-import           Hcompta.Model.Amount.Unit (Unit)
+import qualified Hcompta.Account as Account
+import           Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Write as Amount.Write
 import qualified Hcompta.Format.Ledger as Ledger
 import           Hcompta.Format.Ledger
                   ( Comment
@@ -42,14 +34,12 @@ import           Hcompta.Format.Ledger
                   , Tag
                   , Transaction(..)
                   )
--- import qualified Hcompta.Model.Date as Date
-import           Hcompta.Model.Date (Date)
--- import           Hcompta.Format.Ledger.Journal as Journal
+import qualified Hcompta.Date.Write as Date.Write
 import qualified Hcompta.Format.Ledger.Read as Read
+-- import           Hcompta.Lib.Consable (Consable(..))
 import qualified Hcompta.Lib.Parsec as R
 
-
--- * Printing 'Account'
+-- * Write 'Account'
 
 account :: Posting_Type -> Account -> Doc
 account type_ =
@@ -75,7 +65,7 @@ account type_ =
 account_name :: Account.Name -> Doc
 account_name = W.strict_text
 
--- ** Mesuring 'Account'
+-- ** Measure 'Account'
 
 account_length :: Posting_Type -> Account -> Int
 account_length type_ acct =
@@ -87,99 +77,7 @@ account_length type_ acct =
         Posting_Type_Virtual -> 2
         Posting_Type_Virtual_Balanced -> 2
 
--- * Printing 'Amount'
-
-amount :: Amount -> Doc
-amount Amount.Amount
- { Amount.quantity=qty
- , Amount.style = style@(Style.Style
-        { Style.unit_side
-        , Style.unit_spaced
-        })
- , Amount.unit=unit_
- } = do
-       case unit_side of
-        Just Style.Side_Left ->
-               (unit unit_)
-               <> (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_ /= "" -> W.space; _ -> W.empty })
-               <> unit unit_
-        Nothing ->
-               (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
-               <> unit unit_
-        _ -> W.empty
-
-unit :: Unit -> Doc
-unit = W.yellow . W.strict_text . Unit.text
-
-quantity :: Style -> Quantity -> Doc
-quantity Style.Style
- { Style.fractioning
- , Style.grouping_integral
- , Style.grouping_fractional
- , Style.precision
- } qty = do
-       let Decimal e n = Quantity.round precision qty
-       let num = Prelude.show $ abs $ n
-       let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
-       case e == 0 || precision == 0 of
-        True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
-        False -> do
-               let num_len = length num
-               let padded =
-                       Data.List.concat
-                        [ replicate (fromIntegral e + 1 - num_len) '0'
-                        , num
-                        , replicate (fromIntegral precision - fromIntegral e) '0'
-                        ]
-               let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
-               let default_fractioning =
-                       Data.List.head $
-                       del_grouping_sep grouping_integral $
-                       del_grouping_sep grouping_fractional $
-                       ['.', ',']
-               sign <> do
-               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 -> \x -> case x of
-                                ([], sizes) -> ([[digit]], sizes)
-                                (digits:groups, []) -> ((digit:digits):groups, [])
-                                (digits:groups, curr_sizes@(size:sizes)) ->
-                                       if length digits < size
-                                       then (      (digit:digits):groups, curr_sizes)
-                                       else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
-                        ))
-                        ([], sizes_)
-               del_grouping_sep grouping =
-                       case grouping of
-                        Just (Style.Grouping sep _) -> Data.List.delete sep
-                        _ -> id
-
--- ** Mesuring 'Amount'
-
-amount_length :: Amount -> Int
-amount_length Amount.Amount
- { Amount.quantity=qty
- , Amount.style = style@(Style.Style
-        { Style.unit_spaced
-        })
- , Amount.unit=unit_
- } = do
-       Unit.length unit_
-       + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
-       + quantity_length style qty
+-- ** Measure 'Amount's
 
 amounts_length :: Amount.By_Unit -> Int
 amounts_length amts =
@@ -187,81 +85,10 @@ amounts_length amts =
        then 0
        else
                Data.Map.foldr
-                (\n -> (3 +) . (+) (amount_length n))
+                (\n -> (3 +) . (+) (Amount.Write.amount_length n))
                 (-3) amts
 
-quantity_length :: Style -> Quantity -> Int
-quantity_length Style.Style
- { Style.grouping_integral
- , Style.grouping_fractional
- , Style.precision
- } qty =
-       let Decimal e n = Quantity.round precision qty in
-       let sign_len = if n < 0 then 1 else 0 in
-       let fractioning_len = if e > 0 then 1 else 0 in
-       let num_len = if n == 0 then 0 else (1 +) $ truncate $ logBase 10 $ (fromIntegral (abs n)::Double) in
-       let pad_left_len  = max 0 (fromIntegral e + 1 - num_len) in
-       let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
-       let padded_len = pad_left_len + num_len + pad_right_len in
-       let int_len  = max 1 (num_len - fromIntegral precision) in
-       let frac_len = max 0 (padded_len - int_len) in
-       ( sign_len
-       + fractioning_len
-       + padded_len
-       + maybe 0 (group int_len)  grouping_integral
-       + maybe 0 (group frac_len) grouping_fractional
-       )
-       where
-               group :: Int -> Style.Grouping -> Int
-               group num_len (Style.Grouping _sep sizes_) =
-                       if num_len <= 0
-                       then 0
-                       else loop 0 num_len sizes_
-                       where
-                               loop :: Int -> Int -> [Int] -> Int
-                               loop pad len =
-                                       \x -> case x of
-                                        [] -> 0
-                                        sizes@[size] ->
-                                               let l = len - size in
-                                               if l <= 0 then pad
-                                               else loop (pad + 1) l sizes
-                                        size:sizes ->
-                                               let l = len - size in
-                                               if l <= 0 then pad
-                                               else loop (pad + 1) l sizes
-
--- * Printing 'Date'
-
-date :: Date -> Doc
-date (Time.ZonedTime
- (Time.LocalTime day tod)
- tz@(Time.TimeZone tz_min _ tz_name)) = do
-       let (y, mo, d) = Time.toGregorian day
-       (if y == 0 then W.empty else W.integer y <> sep '/') <> do
-       int2 mo <> do
-       sep '/' <> int2 d <> do
-       (case tod of
-        Time.TimeOfDay 0 0 0 -> W.empty
-        Time.TimeOfDay h m s ->
-               W.space <> int2 h <> do
-               sep ':' <> int2 m <> do
-               (case s of
-                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 -> 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 W.char '0' <> W.int i else W.int i
-               sep :: Char -> Doc
-               sep = W.bold . W.dullblack . W.char
-
--- * Printing 'Comment'
+-- * Write 'Comment'
 
 comment :: Comment -> Doc
 comment com =
@@ -312,7 +139,7 @@ comments prefix =
        Data.List.intersperse W.line .
        Data.List.map (\c -> prefix <> comment c)
 
--- * Printing 'Tag'
+-- * Write 'Tag'
 
 tag :: Tag -> Doc
 tag (n, v) =
@@ -320,14 +147,10 @@ tag (n, v) =
        <> W.char Read.tag_value_sep
        <> (W.dullred $ W.strict_text v)
 
--- * Printing 'Posting'
+-- * Write 'Posting'
 
 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
-posting
- ( max_account_length
- , max_amount_length
- )
- type_
+posting max_posting_length type_
  Posting
  { posting_account=acct
  , posting_amounts
@@ -341,14 +164,13 @@ posting
                case Data.Map.null posting_amounts of
                 True -> account type_ acct
                 False ->
-                       W.fill (max_account_length + 2)
-                        (account type_ acct) <> do
-                       W.fill (max 0
-                        ( max_amount_length
-                        - (fromIntegral $ amounts_length posting_amounts) )) W.empty <> do
+                       let len_acct = account_length type_ acct in
+                       let len_amts = amounts_length posting_amounts in
+                       account type_ acct <> do
+                       W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
                        W.intercalate
                         (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
-                        amount posting_amounts
+                        Amount.Write.amount posting_amounts
        <> (case cmts of
         [] -> W.empty
         [c] -> W.space <> comment c
@@ -359,25 +181,40 @@ status = \x -> case x of
         True  -> W.char '!'
         False -> W.empty
 
--- ** Mesuring 'Posting'
+-- ** Measure 'Posting'
 
-type Posting_Lengths = (Int, Int)
+type Posting_Lengths = (Int)
 
-nil_Posting_Lengths :: Posting_Lengths
-nil_Posting_Lengths = (0, 0)
+postings_lengths
+ :: Posting_Type
+ -> Posting_by_Account
+ -> Posting_Lengths
+ -> Posting_Lengths
+postings_lengths type_ ps pl =
+       Data.Foldable.foldr
+        (\p ->
+               max
+                ( account_length type_ (posting_account p)
+                + amounts_length       (posting_amounts p) )
+        ) pl
+        (Data.Functor.Compose.Compose ps)
 
-postings_lengths :: Posting_Type -> Posting_by_Account -> Posting_Lengths -> Posting_Lengths
-postings_lengths type_ =
-       flip $ Data.Map.foldl $ Data.List.foldl $
-       flip $ \p ->
-       (max (account_length type_ (posting_account p)))
-       ***
-       (max (amounts_length (posting_amounts p)))
-
--- * Printing 'Transaction'
+-- * Write 'Transaction'
 
 transaction :: Transaction -> Doc
-transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
+transaction t = transaction_with_lengths (transaction_lengths t 0) t
+
+transactions :: Foldable ts => ts Transaction -> Doc
+transactions ts = do
+       let transaction_lengths_ =
+               Data.Foldable.foldr transaction_lengths 0 ts
+       Data.Foldable.foldr
+        (\t doc ->
+               transaction_with_lengths transaction_lengths_ t <>
+               (if W.is_empty doc then W.empty else W.line <> doc)
+        )
+        W.empty
+        ts
 
 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
 transaction_with_lengths
@@ -400,7 +237,7 @@ transaction_with_lengths
        (W.hcat $
                Data.List.intersperse
                 (W.char Read.date_sep)
-                (Data.List.map date (first_date:dates))) <> do
+                (Data.List.map Date.Write.date (first_date:dates))) <> do
        (case status_ of
         True -> W.space <> status status_
         False -> W.empty) <> do
@@ -412,30 +249,29 @@ transaction_with_lengths
        (case transaction_comments_after of
         [] -> W.empty
         _  -> comments W.space transaction_comments_after <> W.line) <> do
-       W.vsep $ Data.List.map
-        (\(type_, ps) ->
-               W.intercalate W.line
-                (W.intercalate W.line
-                        (W.vsep . Data.List.map
-                                (posting posting_lengths_ type_)))
-                (Ledger.posting_by_Signs_and_Account ps))
-        [ (Posting_Type_Regular, transaction_postings)
-        , (Posting_Type_Virtual, transaction_virtual_postings)
-        , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
-        ]
+       W.vsep
+        (fmap
+                (\(type_, ps) ->
+                        (W.intercalate W.line
+                                (W.vsep . fmap (posting posting_lengths_ type_))
+                        )
+                        (ps)
+                )
+                [ (Posting_Type_Regular         , transaction_postings)
+                , (Posting_Type_Virtual         , transaction_virtual_postings)
+                , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
+                ]
+        ) <> W.line
 
 code :: Ledger.Code -> Doc
 code = \x -> case x of
         "" -> W.empty
         t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
 
--- ** Mesuring 'Transaction'
+-- ** Measure 'Transaction'
 
 type Transaction_Lengths = Posting_Lengths
 
-nil_Transaction_Lengths :: Posting_Lengths
-nil_Transaction_Lengths = nil_Posting_Lengths
-
 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
 transaction_lengths
  Transaction
@@ -444,36 +280,46 @@ transaction_lengths
  , transaction_balanced_virtual_postings
  } posting_lengths_ = do
        Data.List.foldl
-        (flip (\(type_, ps) -> postings_lengths type_ ps))
+        (flip (uncurry postings_lengths))
         posting_lengths_
         [ (Posting_Type_Regular, transaction_postings)
         , (Posting_Type_Virtual, transaction_virtual_postings)
         , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
         ]
 
--- * Printing 'Journal'
+-- * Write 'Journal'
 
-journal :: Journal -> Doc
-journal Journal
- { journal_transactions
- } = do
-       let transaction_lengths_ =
-               Data.Map.foldr
-                (flip (Data.List.foldr transaction_lengths))
-                nil_Transaction_Lengths
-                journal_transactions
-       Data.Foldable.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
-        journal_transactions
+journal ::
+ ( Foldable ts
+ , Monoid (ts Transaction)
+ ) => Journal (ts Transaction) -> Doc
+journal Journal{ journal_transactions } =
+       transactions journal_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
+data Style
+ =   Style
+ { style_align :: Bool
+ , style_color :: Bool
+ }
+style :: Style
+style =
+       Style
+        { style_align = True
+        , style_color = True
+        }
+
+show :: Style -> Doc -> TL.Text
+show Style{style_color, style_align} =
+       W.displayT .
+       if style_align
+       then W.renderPretty style_color 1.0 maxBound
+       else W.renderCompact style_color
+
+put :: Style -> Handle -> Doc -> IO ()
+put Style{style_color, style_align} handle =
+       W.displayIO handle .
+       if style_align
+       then W.renderPretty style_color 1.0 maxBound
+       else W.renderCompact style_color