]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Print.hs
Ajout : Model.Filter : Test_Tag.
[comptalang.git] / cli / Hcompta / CLI / Command / Print.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 module Hcompta.CLI.Command.Print where
5
6 import Prelude hiding (foldr)
7 -- import Control.Arrow (first)
8 -- import Control.Applicative ((<$>))
9 -- import Control.Monad ((>=>))
10 import Control.Monad.IO.Class (liftIO)
11 import Control.Monad.Trans.Except (runExceptT)
12 import qualified Data.Either
13 import Data.Foldable (foldr)
14 import System.Console.GetOpt
15 ( ArgDescr(..)
16 , OptDescr(..)
17 , usageInfo )
18 import System.Environment as Env (getProgName)
19 import System.Exit (exitWith, ExitCode(..))
20 import qualified System.IO as IO
21
22 import qualified Hcompta.CLI.Args as Args
23 import qualified Hcompta.CLI.Context as Context
24 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
25 import qualified Hcompta.CLI.Write as Write
26 import qualified Hcompta.Format.Ledger as Ledger
27 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
28 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
29 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
30 import qualified Hcompta.Lib.Leijen as W
31 import qualified Hcompta.Model.Filter as Filter
32 import qualified Hcompta.Model.Filter.Read as Filter.Read
33
34 data Ctx
35 = Ctx
36 { ctx_input :: [FilePath]
37 , ctx_align :: Bool
38 } deriving (Eq, Show)
39
40 nil :: Ctx
41 nil =
42 Ctx
43 { ctx_input = []
44 , ctx_align = True
45 }
46
47 usage :: IO String
48 usage = do
49 bin <- Env.getProgName
50 return $unlines $
51 [ "SYNTAX "
52 , " "++bin++" print [option..]"
53 , ""
54 , usageInfo "OPTIONS" options
55 ]
56
57 options :: Args.Options Ctx
58 options =
59 [ Option "h" ["help"]
60 (NoArg (\_context _ctx -> do
61 usage >>= IO.hPutStr IO.stderr
62 exitWith ExitSuccess))
63 "show this help"
64 , Option "i" ["input"]
65 (ReqArg (\s _context ctx -> do
66 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
67 "read data from given file, can be use multiple times"
68 , Option "" ["align"]
69 (OptArg (\arg context ctx -> do
70 ctx_align <- case arg of
71 Nothing -> return $ True
72 Just "yes" -> return $ True
73 Just "no" -> return $ False
74 Just _ -> Write.fatal context $
75 W.text "--align option expects \"yes\", or \"no\" as value"
76 return $ ctx{ctx_align})
77 "[yes|no]")
78 "align output"
79 ]
80
81 run :: Context.Context -> [String] -> IO ()
82 run context args = do
83 (ctx, text_filters) <- Args.parse context usage options (nil, args)
84 read_journals <- do
85 CLI.Ledger.paths context $ ctx_input ctx
86 >>= do
87 mapM $ \path -> do
88 liftIO $ runExceptT $ Ledger.Read.file path
89 >>= \x -> case x of
90 Left ko -> return $ Left (path, ko)
91 Right ok -> return $ Right ok
92 >>= return . Data.Either.partitionEithers
93 case read_journals of
94 (errs@(_:_), _journals) ->
95 (flip mapM_) errs $ \(_path, err) -> do
96 Write.fatal context $ err
97 ([], journals) -> do
98 (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <-
99 (flip mapM) text_filters $ \s ->
100 liftIO $ Filter.Read.read Filter.Read.test_transaction s
101 >>= \f -> case f of
102 Left ko -> Write.fatal context $ ko
103 Right ok -> return ok
104 Write.debug context $ "transaction_filter: " ++ show filters
105 style_color <- Write.with_color context IO.stdout
106 let sty = Ledger.Write.Style
107 { Ledger.Write.style_align = ctx_align ctx
108 , Ledger.Write.style_color
109 }
110 let transactions =
111 foldr
112 (Ledger.Journal.fold
113 (flip (foldr
114 (flip (foldr
115 (\tr ->
116 case Filter.test
117 (foldr Filter.And Filter.Any filters) tr of
118 False -> id
119 True -> (:) tr
120 ))))
121 . Ledger.journal_transactions))
122 []
123 journals
124 Ledger.Write.put sty IO.stdout $ do
125 Ledger.Write.transactions transactions