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