]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Print.hs
Correction : Lib.Parsec : détection et propagation des erreurs.
[comptalang.git] / cli / Hcompta / CLI / Command / Print.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 module Hcompta.CLI.Command.Print where
3
4 import Control.Arrow (first)
5 import Control.Applicative ((<$>))
6 import Control.Monad.IO.Class (liftIO)
7 import Control.Monad.Trans.Except (runExceptT)
8 import qualified Data.Either
9 import qualified Data.List
10 import System.Console.GetOpt
11 ( ArgDescr(..)
12 , OptDescr(..)
13 , usageInfo )
14 import System.Environment as Env (getProgName)
15 import System.Exit (exitWith, ExitCode(..))
16 import qualified System.IO as IO
17
18 import qualified Hcompta.CLI.Args as Args
19 import qualified Hcompta.CLI.Context as Context
20 import qualified Hcompta.CLI.Write as Write
21 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
22 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
23 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
24 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
25 import qualified Hcompta.Model.Journal
26
27 data Ctx
28 = Ctx
29 { ctx_input :: [FilePath]
30 } deriving (Eq, Show)
31
32 nil :: Ctx
33 nil =
34 Ctx
35 { ctx_input = []
36 }
37
38 usage :: IO String
39 usage = do
40 bin <- Env.getProgName
41 return $unlines $
42 [ "SYNTAX "
43 , " "++bin++" print [option..]"
44 , ""
45 , usageInfo "OPTIONS" options
46 ]
47
48 options :: Args.Options Ctx
49 options =
50 [ Option "h" ["help"]
51 (NoArg (\_context _ctx -> do
52 usage >>= IO.hPutStr IO.stderr
53 exitWith ExitSuccess))
54 "show this help"
55 , Option "i" ["input"]
56 (ReqArg (\s _context ctx -> do
57 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
58 "read data from given file, can be use multiple times"
59 ]
60
61 run :: Context.Context -> [String] -> IO ()
62 run context args = do
63 (ctx, _) <-
64 first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
65 Args.parse context usage options (nil, args)
66 CLI.Ledger.paths context $ ctx_input ctx
67 >>= do mapM $ \path -> do
68 liftIO $ runExceptT $
69 Ledger.Read.file path
70 >>= \x -> case x of
71 Left ko -> return $ Left (path, ko)
72 Right ok -> return $ Right ok
73 >>= return . Data.Either.partitionEithers
74 >>= \x -> case x of
75 (kos@(_:_), _oks) ->
76 (flip mapM_) kos $ \(_path, ko) -> Write.fatal context $ show ko
77 ([], journals) -> do
78 CLI.Ledger.equilibre context journals
79 with_color <- Write.with_color context IO.stdout
80 let journal
81 = Hcompta.Model.Journal.unions $
82 Data.List.map Ledger.Journal.to_Model journals
83 Ledger.Write.put with_color IO.stdout $ do
84 Ledger.Write.journal journal