]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Journals.hs
Ajout : Chart : Tags : Équilibre.
[comptalang.git] / cli / Hcompta / CLI / Command / Journals.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TupleSections #-}
8 module Hcompta.CLI.Command.Journals where
9
10 import Control.Monad (Monad(..), forM_, liftM, mapM)
11 import Control.Monad.IO.Class (liftIO)
12 import Control.Monad.Trans.Except (runExceptT)
13 import Data.Either (Either(..), partitionEithers)
14 import Data.Foldable (Foldable(..))
15 import Data.List ((++), replicate)
16 import Data.Monoid (Monoid(..), (<>))
17 import Data.String (String)
18 import Text.Show (Show)
19 import Prelude (($), Bounded(..), FilePath, IO, flip, unlines)
20 import System.Console.GetOpt
21 ( ArgDescr(..)
22 , OptDescr(..)
23 , usageInfo )
24 import System.Environment as Env (getProgName)
25 import System.Exit (exitSuccess)
26 import qualified System.IO as IO
27
28 import Hcompta.Chart (Chart)
29 import qualified Hcompta.CLI.Args as Args
30 import Hcompta.CLI.Context (Context)
31 import qualified Hcompta.CLI.Context as Context
32 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
33 import qualified Hcompta.CLI.Write as Write
34 import qualified Hcompta.Format.Ledger as Ledger
35 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
36 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
37 import Hcompta.Lib.Consable (Consable(..))
38 import qualified Hcompta.Lib.Leijen as W
39
40 data Ctx
41 = Ctx
42 { ctx_input :: [FilePath]
43 } deriving (Show)
44
45 nil :: Ctx
46 nil =
47 Ctx
48 { ctx_input = []
49 }
50
51 usage :: IO String
52 usage = do
53 bin <- Env.getProgName
54 let pad = replicate (length bin) ' '
55 return $unlines $
56 [ "SYNTAX "
57 , " "++bin++" stats [-i FILE_JOURNAL]"
58 , " "++pad++" [FILE_JOURNAL] [...]"
59 , ""
60 , usageInfo "OPTIONS" options
61 ]
62
63 options :: Args.Options Ctx
64 options =
65 [ Option "h" ["help"]
66 (NoArg (\_context _ctx -> do
67 usage >>= IO.hPutStr IO.stderr
68 exitSuccess))
69 "show this help"
70 , Option "i" ["input"]
71 (ReqArg (\s _context ctx -> do
72 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
73 "read data from given file, multiple uses merge the data as would a concatenation do"
74 ]
75
76 run :: Context.Context -> [String] -> IO ()
77 run context args = do
78 (ctx, inputs) <- Args.parse context usage options (nil, args)
79 read_journals <-
80 liftM Data.Either.partitionEithers $ do
81 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
82 >>= do
83 mapM $ \path -> do
84 liftIO $ runExceptT $ Ledger.Read.file
85 (Ledger.Read.context () Ledger.journal)
86 path
87 >>= \x -> case x of
88 Left ko -> return $ Left (path, ko)
89 Right ok -> return $ Right ok
90 case read_journals of
91 (errs@(_:_), _journals) ->
92 forM_ errs $ \(_path, err) -> do
93 Write.fatal context $ err
94 ([], journals) -> do
95 let files = ledger_journals ctx journals
96 style_color <- Write.with_color context IO.stdout
97 W.displayIO IO.stdout $ do
98 W.renderPretty style_color 1.0 maxBound $ do
99 doc_journals context ctx files
100
101 newtype Journals t = Journals ()
102 deriving (Show)
103 instance Monoid (Journals t) where
104 mempty = Journals ()
105 mappend _ _ = mempty
106
107 instance Consable () Journals t where
108 mcons () _t !_js = mempty
109
110 ledger_journals
111 :: Ctx
112 -> [ Ledger.Journal (Journals (Chart, Ledger.Transaction)) ]
113 -> [FilePath]
114 ledger_journals _ctx =
115 Data.Foldable.foldl'
116 (flip $ Ledger.Journal.fold
117 (\Ledger.Journal{Ledger.journal_file=f} ->
118 mappend [f]))
119 mempty
120
121 doc_journals
122 :: Context
123 -> Ctx
124 -> [FilePath]
125 -> W.Doc
126 doc_journals _context _ctx =
127 foldr
128 (\file doc -> doc <> W.toDoc () file <> W.line)
129 W.empty