]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Balance.hs
Correction : Lib.Parsec : détection et propagation des erreurs.
[comptalang.git] / cli / Hcompta / CLI / Command / Balance.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE TupleSections #-}
4 module Hcompta.CLI.Command.Balance where
5
6 import Control.Monad.IO.Class (liftIO)
7 import Control.Monad.Trans.Except (runExceptT)
8 import qualified Data.Either
9 import qualified Data.Foldable
10 import qualified Data.List
11 import qualified Data.Map
12 import qualified Data.Text.Lazy as TL
13 import System.Console.GetOpt
14 ( ArgDescr(..)
15 , OptDescr(..)
16 , usageInfo
17 )
18 import System.Environment as Env (getProgName)
19 import System.Exit (exitWith, ExitCode(..))
20 import qualified System.IO as IO
21 import Text.Show.Pretty (ppShow) -- TODO: may be not necessary
22
23 import qualified Hcompta.CLI.Args as Args
24 import qualified Hcompta.CLI.Context as Context
25 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
26 import qualified Hcompta.CLI.Write as Write
27 import qualified Hcompta.Calc.Balance as Balance
28 import qualified Hcompta.Format.Ledger.Journal
29 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
30 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
31 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
32 import qualified Hcompta.Lib.Leijen as W
33 import Hcompta.Lib.Leijen ((<>))
34 import qualified Hcompta.Model.Amount as Amount
35 import qualified Hcompta.Model.Transaction.Posting as Posting
36 -- import qualified Hcompta.Format.Ledger.Write
37
38 data Ctx
39 = Ctx
40 { ctx_input :: [FilePath]
41 , ctx_redundant :: Bool
42 } deriving (Eq, Show)
43
44 nil :: Ctx
45 nil =
46 Ctx
47 { ctx_input = []
48 , ctx_redundant = False
49 }
50
51 usage :: IO String
52 usage = do
53 bin <- Env.getProgName
54 return $ unlines $
55 [ "SYNTAX "
56 , " "++bin++" balance [option..]"
57 , ""
58 , usageInfo "OPTIONS" options
59 ]
60
61 options :: Args.Options Ctx
62 options =
63 [ Option "h" ["help"]
64 (NoArg (\_context _ctx -> do
65 usage >>= IO.hPutStr IO.stderr
66 exitWith ExitSuccess))
67 "show this help"
68 , Option "i" ["input"]
69 (ReqArg (\s _context ctx -> do
70 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
71 "read data from given file, can be use multiple times"
72 , Option "" ["redundant"]
73 (OptArg (\arg context ctx -> do
74 redundant <- case arg of
75 Nothing -> return $ True
76 Just "yes" -> return $ True
77 Just "no" -> return $ False
78 Just _ -> Write.fatal context
79 "--redundant option expects \"yes\", or \"no\" as value"
80 return $ ctx{ctx_redundant=redundant})
81 "[yes|no]")
82 "also print accounts with zero amount or the same amounts than its ascending account"
83 ]
84
85 run :: Context.Context -> [String] -> IO ()
86 run context args = do
87 (ctx, _) <- Args.parse context usage options (nil, args)
88 koks <- do
89 CLI.Ledger.paths context $ ctx_input ctx
90 >>= do mapM $ \path -> do
91 liftIO $ runExceptT $
92 Ledger.Read.file path
93 >>= \x -> case x of
94 Left ko -> return $ Left (path, ko)
95 Right ok -> return $ Right ok
96 >>= return . Data.Either.partitionEithers
97 case koks of
98 (kos@(_:_), _oks) ->
99 (flip mapM_) kos $ \(_path, ko) ->
100 Write.fatal context $ show ko
101 ([], journals) -> do
102 let balance =
103 Data.List.foldl'
104 (\b j -> Balance.journal_with_virtual
105 (Hcompta.Format.Ledger.Journal.to_Model j) b)
106 Balance.nil
107 journals
108 Write.debug context $ ppShow $ balance
109 Write.debug context $ ppShow $
110 Lib.TreeMap.flatten (const ()) (Balance.by_account balance)
111 let expanded = Balance.expanded $ Balance.by_account balance
112 Write.debug context $ ppShow $ expanded
113 with_color <- Write.with_color context IO.stdout
114 Ledger.Write.put with_color IO.stdout $ do
115 let (max_amount_length, accounts) = write_accounts ctx expanded
116 accounts <> do
117 (if W.is_empty accounts
118 then W.empty
119 else (W.bold $ W.dullblack $
120 W.text (TL.pack $ replicate max_amount_length '-') <>
121 (if max_amount_length <= 0 then W.empty else W.line))) <> do
122 write_amounts max_amount_length $
123 Data.Map.map Balance.amount $
124 (Balance.by_unit balance)
125
126 write_accounts :: Ctx -> Balance.Expanded -> (Int, W.Doc)
127 write_accounts ctx accounts = do
128 let max_amount_length =
129 uncurry (+) $
130 Data.Foldable.foldl
131 (\(len, plus) Balance.Account_Sum_Expanded{Balance.inclusive=amounts} ->
132 let amounts_ = (if ctx_redundant ctx then amounts else Data.Map.filter (not . Amount.is_zero) amounts) in
133 ( Data.Map.foldr (max . Ledger.Write.amount_length) len amounts
134 , (if Data.Map.size amounts_ > 1
135 then 2 -- NOTE: length "+ "
136 else plus)
137 )
138 )
139 (0, 0) accounts
140 (max_amount_length,) $ do
141 Lib.TreeMap.foldl_with_Path_and_Node
142 (\doc account node amounts ->
143 let descendants = Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node) in
144 if not (ctx_redundant ctx) && (
145 Data.Map.size
146 (Data.Map.filter
147 (not . Amount.is_zero)
148 (Balance.exclusive amounts)) == 0 &&
149 Data.Map.size
150 (Data.Map.filter
151 ( maybe False (not . Amount.are_zero . Balance.inclusive)
152 . Lib.TreeMap.node_value
153 ) descendants) == 1
154 )
155 then doc
156 else
157 doc <> Data.Map.foldl
158 (\doc_ amount ->
159 if not (ctx_redundant ctx) && Amount.is_zero amount
160 then doc_
161 else
162 doc_ <>
163 (if W.is_empty doc_
164 then do
165 W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
166 Ledger.Write.amount amount <> do
167 W.space <> W.space <> do
168 Ledger.Write.account Posting.Type_Regular account
169 else do
170 (W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
171 W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
172 Ledger.Write.amount amount) <> do
173 W.line
174 ) W.empty (Balance.inclusive amounts)
175 )
176 W.empty accounts
177
178 write_amounts :: Int -> Amount.By_Unit -> W.Doc
179 write_amounts max_amount_length_ amounts = do
180 let max_amount_length =
181 Data.Map.foldr
182 (max . Ledger.Write.amount_length)
183 max_amount_length_ amounts
184 (if Data.Map.size amounts > 1
185 then W.space <> W.space
186 else W.empty) <> do
187 W.intercalate
188 (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
189 (\amount ->
190 let len =
191 max_amount_length
192 - Ledger.Write.amount_length amount
193 - (if Data.Map.size amounts > 1
194 then 2 -- NOTE: length "+ "
195 else 0) in
196 W.fill len W.empty <> do
197 Ledger.Write.amount amount)
198 amounts <> do
199 (if Data.Map.null amounts then W.empty else W.line)