{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Format.Ledger where
-import Prelude hiding (error)
-import Control.Exception (tryJust)
-import Control.Monad (guard)
-import qualified Data.List
+-- import Control.Monad.Trans.Except (ExceptT(..))
+import Data.Foldable (Foldable(..))
+import Data.Function ((.))
+import qualified Data.List as List
+import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
-import System.Environment as Env (getEnv)
-import System.IO.Error (isDoesNotExistError)
-import qualified Text.Parsec as Parsec
-import qualified Text.Parsec.Error as Parsec.Error
+-- import Control.DeepSeq (NFData)
+import Prelude (($))
+-- import System.IO (IO)
+import Text.Show (Show(..))
+import Hcompta.Date (Date)
+import qualified Hcompta.Balance as Balance
+-- import qualified Hcompta.CLI.Format as CLI.Format
+-- import Hcompta.CLI.Lang (Lang)
+import qualified Hcompta.CLI.Lang as Lang
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Read as Ledger
+import qualified Hcompta.Format.Ledger.Write as Ledger
+-- import Hcompta.Lib.Consable (Consable)
+import Hcompta.Lib.Leijen (ToDoc(..))
import qualified Hcompta.Lib.Leijen as W
-import Hcompta.Lib.Leijen (ToDoc(..), (<>))
-import qualified Hcompta.Lib.Parsec as Lib.Parsec
-import qualified Hcompta.Calc.Balance as Calc.Balance
-import qualified Hcompta.CLI.Context as Context
-import Hcompta.CLI.Context (Context)
-import qualified Hcompta.CLI.I18N as I18N
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Model.Filter.Read as Filter.Read
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
-import qualified Hcompta.Format.Ledger.Write as Ledger.Write
-import qualified Hcompta.Model.Amount as Amount
+-- import qualified Hcompta.Lib.Parsec as Parsec
+import qualified Hcompta.Polarize as Polarize
+import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
--- | Return 'FilePath's containing 'Hcompta.Format.Ledger.Journal's:
---
--- * either those given if any,
--- * or the one in LEDGER_FILE environment variable if any,
--- * or the one in LEDGER environment variable if any.
-paths :: Context.Context -> [FilePath] -> IO [FilePath]
-paths context [] = do
- tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER_FILE"
- >>= \x -> case x of
- Right ok -> return [ok]
- Left _ko -> do
- tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER"
- >>= \xx -> case xx of
- Right ok -> return [ok]
- Left _ko -> do
- let langs = Context.langs context
- Write.fatal context $
- I18N.render langs
- I18N.Message_no_ledger_file_given
-paths _context ps = return ps
-
-instance ToDoc Context Parsec.SourcePos where
- toDoc context pos = do
- let langs = Context.langs context
- I18N.render langs $ do
- case Parsec.sourceName pos of
- "" -> I18N.Message_at
- (Parsec.sourceLine pos)
- (Parsec.sourceColumn pos)
- path -> I18N.Message_in_file path
- (Parsec.sourceLine pos)
- (Parsec.sourceColumn pos)
-
-instance ToDoc Context e => ToDoc Context [Lib.Parsec.Error e] where
- toDoc context errors =
- W.vsep $ do
- (flip map) errors $ (\error ->
- case error of
- Lib.Parsec.Error_At pos errs -> W.vsep $
- [ toDoc context pos
- , toDoc context errs
- ]
- Lib.Parsec.Error_Parser err ->
- W.vsep $
- [ toDoc context (Parsec.errorPos err)
- , showErrorMessages
- (Parsec.Error.errorMessages err)
- ]
- Lib.Parsec.Error_Custom pos err -> W.vsep $
- [ toDoc context pos
- , toDoc context err
- ]
- )
- where
- langs = Context.langs context
- showErrorMessages :: [Parsec.Error.Message] -> W.Doc
- showErrorMessages msgs
- | null msgs = i18n $ I18N.Message_unknown
- | otherwise = W.vsep $ -- clean $
- [showSysUnExpect, showUnExpect, showExpect, showMessages]
- where
- i18n = I18N.render langs
- (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
- (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1
- (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2
-
- showExpect = showMany (Just (i18n . I18N.Message_expect)) expect
- showUnExpect = showMany (Just (i18n . I18N.Message_unexpect)) unExpect
- showSysUnExpect
- | not (null unExpect) || null sysUnExpect = W.empty
- | null firstMsg = i18n $ I18N.Message_sysunexpect_end_of_input
- | otherwise = i18n $ I18N.Message_sysunexpect firstMsg
- where
- firstMsg = Parsec.Error.messageString (head sysUnExpect)
-
- showMessages = showMany Nothing messages
-
- -- helpers
- showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
- showMany pre msgs_ =
- case clean (map Parsec.Error.messageString msgs_) of
- [] -> W.empty
- ms ->
- case pre of
- Nothing -> commasOr ms
- Just p -> p $ commasOr ms
-
- commasOr :: [String] -> W.Doc
- commasOr [] = W.empty
- commasOr [m] = W.text $ TL.pack m
- commasOr ms = commaSep (init ms)
- <> (W.space <> i18n I18N.Message_or <> W.space)
- <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
- commaSep = W.intercalate (W.comma <> W.space)
- (W.bold . W.dullblack . W.text . TL.pack)
- . clean
-
- clean = Data.List.nub . filter (not . null)
-
-instance ToDoc Context Ledger.Read.Error where
- toDoc context err =
+instance Lang.Translate Ledger.Read_Error W.Doc where
+ translate lang err =
case err of
- Ledger.Read.Error_year_or_day_is_missing ->
- I18N.render langs $ I18N.Message_year_or_day_is_missing
- Ledger.Read.Error_invalid_date (y, m, d) ->
- I18N.render langs $ I18N.Message_invalid_date y m d
- Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
- I18N.render langs $ I18N.Message_invalid_time_of_day h m s
- Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
- i18n_transaction_not_equilibrated tr unit_sums
- I18N.Message_the_following_transaction_is_not_equilibrated_because
- Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
- i18n_transaction_not_equilibrated tr unit_sums
- I18N.Message_the_following_virtual_transaction_is_not_equilibrated_because
- Ledger.Read.Error_reading_file file_path exn -> W.vsep $
- [ I18N.render langs $
- I18N.Message_failed_to_read_file file_path
+ Ledger.Read_Error_date date -> toDoc lang date
+ Ledger.Read_Error_transaction_not_equilibrated styles tr unit_sums ->
+ i18n_transaction_not_equilibrated styles tr unit_sums
+ Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
+ Ledger.Read_Error_virtual_transaction_not_equilibrated styles tr unit_sums ->
+ i18n_transaction_not_equilibrated styles tr unit_sums
+ Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
+ Ledger.Read_Error_reading_file file_path exn ->
+ W.vsep $
+ [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
, W.text $ TL.pack $ show exn
]
- Ledger.Read.Error_including_file file_path errs -> W.vsep $
- [ I18N.render langs $
- I18N.Message_failed_to_include_file file_path
- , toDoc context errs
+ Ledger.Read_Error_including_file file_path errs ->
+ W.vsep $
+ [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
+ , Lang.translate lang errs
]
where
- langs = Context.langs context
- i18n_transaction_not_equilibrated tr unit_sums msg =
+ i18n_transaction_not_equilibrated styles tr unit_sums msg =
W.vsep $
- [ I18N.render langs msg
- , W.vsep $ Data.List.map
- (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} ->
- let amt = Calc.Balance.amount_sum_balance unit_sum_amount in
- I18N.render langs $
- I18N.Message_unit_sums_up_to_the_non_null_amount
- (Amount.unit amt) amt
+ [ Lang.translate lang msg
+ , W.vsep $ List.map
+ (\(unit, Balance.Unit_Sum{Balance.unit_sum_quantity}) ->
+ Lang.translate lang $
+ Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
+ Ledger.amount_styled styles $
+ Ledger.Amount unit $
+ Polarize.depolarize unit_sum_quantity
) unit_sums
, W.space
- , Ledger.Write.transaction tr
+ , Ledger.write_transaction styles tr
]
-instance ToDoc Context Filter.Read.Error where
- toDoc context err =
- case err of
- Filter.Read.Error_Unknown -> toDoc context ("error"::String)
+instance Leijen.Table.Cell_of_forall_param Ledger.Journal Date where
+ cell_of_forall_param _ctx date =
+ Leijen.Table.cell
+ { Leijen.Table.cell_content = Ledger.write_date date
+ , Leijen.Table.cell_width = Ledger.write_date_length date
+ }
+instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Account where
+ cell_of_forall_param _ctx account =
+ let posting_type = Ledger.Posting_Type_Regular in
+ Leijen.Table.cell
+ { Leijen.Table.cell_content = Ledger.write_account posting_type account
+ , Leijen.Table.cell_width = Ledger.write_account_length posting_type account
+ }
+instance Leijen.Table.Cell_of_forall_param Ledger.Journal (Ledger.Unit, Ledger.Quantity) where
+ cell_of_forall_param j (unit, qty) =
+ let sty = Ledger.journal_amount_styles j in
+ let amt = Ledger.Amount unit qty in
+ let sa = Ledger.amount_styled sty amt in
+ Leijen.Table.cell
+ { Leijen.Table.cell_content = Ledger.write_amount sa
+ , Leijen.Table.cell_width = Ledger.write_amount_length sa
+ }
+instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Wording where
+ cell_of_forall_param _j w =
+ Leijen.Table.cell
+ { Leijen.Table.cell_content = toDoc () w
+ , Leijen.Table.cell_width = Text.length w
+ }
+
+instance Foldable f => W.Leijen_of_forall_param Ledger.Journal (f Ledger.Transaction) where
+ leijen_of_forall_param =
+ Ledger.write_transactions .
+ Ledger.journal_amount_styles
sourcephile / git / comptalang.git / blobdiff