]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Journals.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / CLI / Command / Journals.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TupleSections #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 module Hcompta.CLI.Command.Journals where
14
15 import Control.Arrow ((+++))
16 import Control.Monad (Monad(..), mapM)
17 import Control.Monad.IO.Class (liftIO)
18 import Data.Either (Either(..), partitionEithers)
19 import Data.Foldable (Foldable(..))
20 import Data.Function (($), (.), const)
21 import Data.Functor ((<$>))
22 import Data.List ((++))
23 import Data.Maybe (Maybe(..))
24 import Data.Monoid (Monoid(..), (<>))
25 import Data.String (String)
26 import Prelude (Bounded(..), FilePath, IO, unlines)
27 import System.Console.GetOpt
28 ( ArgDescr(..)
29 , OptDescr(..)
30 , usageInfo )
31 import qualified System.Environment as Env
32 import System.Exit (exitSuccess)
33 import qualified System.IO as IO
34 import Text.Show (Show)
35
36 import qualified Hcompta.CLI.Args as Args
37 import qualified Hcompta.CLI.Context as C
38 import qualified Hcompta.CLI.Env as CLI.Env
39
40 import qualified Hcompta.CLI.Format as Format
41 import Hcompta.CLI.Format (Format(..), Formats)
42 import Hcompta.CLI.Format.Ledger ()
43 import Hcompta.CLI.Format.JCC ()
44 import qualified Hcompta.CLI.Lang as Lang
45 import qualified Hcompta.CLI.Write as Write
46
47
48 -- import qualified Hcompta.Lib.Parsec as R
49 import qualified Hcompta.JCC as JCC
50 import qualified Hcompta.Ledger as Ledger
51 import qualified Text.WalderLeijen.ANSI.Text as W
52
53 data Context
54 = Context
55 { ctx_input :: [FilePath]
56 , ctx_input_format :: Formats
57 } deriving (Show)
58
59 context :: Context
60 context =
61 Context
62 { ctx_input = []
63 , ctx_input_format = mempty
64 }
65
66 usage :: C.Context -> IO String
67 usage c = do
68 bin <- Env.getProgName
69 return $ unlines $
70 [ C.translate c Lang.Section_Description
71 , " "++C.translate c Lang.Help_Command_Journals
72 , ""
73 , C.translate c Lang.Section_Syntax
74 , " "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
75 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
76 , ""
77 , usageInfo (C.translate c Lang.Section_Options) (options c)
78 ]
79
80 options :: C.Context -> Args.Options Context
81 options c =
82 [ Option "h" ["help"]
83 (NoArg (\_ctx -> do
84 usage c >>= IO.hPutStr IO.stderr
85 exitSuccess)) $
86 C.translate c Lang.Help_Option_Help
87 , Option "i" ["input"]
88 (ReqArg (\s ctx ->
89 return $ ctx{ctx_input=s:ctx_input ctx}) $
90 C.translate c Lang.Type_File_Journal) $
91 C.translate c Lang.Help_Option_Input
92 , Option "f" ["input-format"]
93 (OptArg (\arg ctx -> do
94 ctx_input_format <- case arg of
95 Nothing -> return $ Format_JCC ()
96 Just "jcc" -> return $ Format_JCC ()
97 Just "ledger" -> return $ Format_Ledger ()
98 Just _ -> Write.fatal c $
99 W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
100 return $ ctx{ctx_input_format})
101 "[jcc|ledger]")
102 "input format"
103 ]
104
105 run :: C.Context -> [String] -> IO ()
106 run c args = do
107 (ctx, inputs) <- Args.parse c usage options (context, args)
108 input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
109 read_journals <- mapM (liftIO . journal_read ctx) input_paths
110 case partitionEithers read_journals of
111 (errs@(_:_), _journals) -> Write.fatals c errs
112 ([], journals) -> do
113 with_color <- Write.with_color c IO.stdout
114 W.displayIO IO.stdout $
115 W.renderPretty with_color 1.0 maxBound $
116 W.toDoc () $
117 mconcat journals
118
119 -- * Class 'Journal'
120
121 class
122 ( Format.Journal_Monoid (j m)
123 , Format.Journal_Read j
124 ) => Journal j m where
125 journal_files :: j m -> [FilePath]
126
127 -- JCC
128 instance Journal JCC.Journal Journals_JCC where
129 journal_files = JCC.journal_files
130
131 -- Ledger
132 instance Journal Ledger.Journal Journals_Ledger where
133 journal_files = Ledger.journal_files
134
135 type Journals_JCC = ()
136 type Journals_Ledger = ()
137
138 -- * Type 'Journals'
139
140 newtype Journals =
141 Journals [FilePath]
142 deriving (Show)
143 instance Monoid Journals where
144 mempty = Journals []
145 mappend (Journals x) (Journals y) =
146 Journals (mappend x y)
147 mconcat = foldl' mappend mempty
148 instance W.ToDoc () Journals where
149 toDoc () (Journals files) =
150 foldr
151 (\file doc -> doc <> W.toDoc () file <> W.line)
152 W.empty files
153
154 type Journal_Read_Cons txn = txn -> ()
155 journal_read
156 :: Context -> FilePath
157 -> IO (Either (Format.Message W.Doc) Journals)
158 journal_read ctx =
159 case ctx_input_format ctx of
160 Format_JCC () ->
161 let wrap (j::JCC.Journal Journals_JCC) =
162 Format.journal_fold journals_cons j mempty in
163 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
164 = const () in
165 (((+++) Format.Message wrap) <$>) .
166 Format.journal_read cons
167 Format_Ledger () ->
168 let wrap (j::Ledger.Journal Journals_Ledger) =
169 Format.journal_fold journals_cons j mempty in
170 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
171 = const () in
172 (((+++) Format.Message wrap) <$>) .
173 Format.journal_read cons
174
175 journals_cons :: Journal j m => j m -> Journals -> Journals
176 journals_cons j (Journals files) =
177 Journals (journal_files j ++ files)