]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Journals.hs
Correction : rétro support de GHC 7.6.3 (Debian/jessie).
[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.DeepSeq (NFData(..))
11 import Control.Monad (Monad(..), forM_, liftM, mapM)
12 import Control.Monad.IO.Class (liftIO)
13 import Control.Monad.Trans.Except (runExceptT)
14 import Data.Either (Either(..), partitionEithers)
15 import Data.Foldable (Foldable(..))
16 import Data.List ((++))
17 import Data.Monoid (Monoid(..), (<>))
18 import Data.String (String)
19 import Text.Show (Show)
20 import Prelude (($), Bounded(..), FilePath, IO, flip, unlines)
21 import System.Console.GetOpt
22 ( ArgDescr(..)
23 , OptDescr(..)
24 , usageInfo )
25 import System.Environment as Env (getProgName)
26 import System.Exit (exitSuccess)
27 import qualified System.IO as IO
28
29 import qualified Hcompta.CLI.Args as Args
30 import qualified Hcompta.CLI.Context as C
31 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
32 import qualified Hcompta.CLI.Lang as Lang
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 :: C.Context -> IO String
52 usage c = do
53 bin <- Env.getProgName
54 return $ unlines $
55 [ C.translate c Lang.Section_Description
56 , " "++C.translate c Lang.Help_Command_Journals
57 , ""
58 , C.translate c Lang.Section_Syntax
59 , " "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
60 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
61 , ""
62 , usageInfo (C.translate c Lang.Section_Options) (options c)
63 ]
64
65 options :: C.Context -> Args.Options Ctx
66 options c =
67 [ Option "h" ["help"]
68 (NoArg (\_ctx -> do
69 usage c >>= IO.hPutStr IO.stderr
70 exitSuccess)) $
71 C.translate c Lang.Help_Option_Help
72 , Option "i" ["input"]
73 (ReqArg (\s ctx -> do
74 return $ ctx{ctx_input=s:ctx_input ctx}) $
75 C.translate c Lang.Type_File_Journal) $
76 C.translate c Lang.Help_Option_Input
77 ]
78
79 run :: C.Context -> [String] -> IO ()
80 run c args = do
81 (ctx, inputs) <-
82 Args.parse c usage options (nil, args)
83 read_journals <-
84 liftM Data.Either.partitionEithers $ do
85 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
86 >>= do
87 mapM $ \path -> do
88 liftIO $ runExceptT $ Ledger.Read.file
89 (Ledger.Read.context () Ledger.journal)
90 path
91 >>= \x -> case x of
92 Left ko -> return $ Left (path, ko)
93 Right ok -> return $ Right ok
94 case read_journals of
95 (errs@(_:_), _journals) ->
96 forM_ errs $ \(_path, err) -> do
97 Write.fatal c $ err
98 ([], journals) -> do
99 let files = ledger_journals ctx journals
100 style_color <- Write.with_color c IO.stdout
101 W.displayIO IO.stdout $ do
102 W.renderPretty style_color 1.0 maxBound $ do
103 doc_journals c ctx files
104
105 newtype Journals t = Journals ()
106 deriving (Show)
107 instance Monoid (Journals t) where
108 mempty = Journals ()
109 mappend _ _ = mempty
110 instance NFData t => NFData (Journals t) where
111 rnf (Journals t) = rnf t
112
113 instance Consable () Journals t where
114 mcons () _t !_js = mempty
115
116 ledger_journals
117 :: Ctx
118 -> [Ledger.Journal (Journals (Ledger.Chart_With Ledger.Transaction))]
119 -> [FilePath]
120 ledger_journals _ctx =
121 Data.Foldable.foldl'
122 (flip $ Ledger.Journal.fold
123 (\Ledger.Journal{Ledger.journal_file=f} ->
124 mappend [f]))
125 mempty
126
127 doc_journals
128 :: C.Context
129 -> Ctx
130 -> [FilePath]
131 -> W.Doc
132 doc_journals _context _ctx =
133 foldr
134 (\file doc -> doc <> W.toDoc () file <> W.line)
135 W.empty