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.Monad (liftM, forM_)
  11 import           Control.Monad.IO.Class (liftIO)
  12 import           Control.Monad.Trans.Except (runExceptT)
  13 import qualified Data.Either
  14 import qualified Data.Foldable
  15 import           Data.Monoid ((<>))
  16 import           System.Console.GetOpt
  17                  ( ArgDescr(..)
  18                  , OptDescr(..)
  19                  , usageInfo )
  20 import           System.Environment as Env (getProgName)
  21 import           System.Exit (exitSuccess)
  22 import qualified System.IO as IO
  23
  24 import qualified Hcompta.CLI.Args as Args
  25 import qualified Hcompta.CLI.Context as Context
  26 import           Hcompta.CLI.Context (Context)
  27 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  28 import qualified Hcompta.CLI.Write as Write
  29 import qualified Hcompta.Format.Ledger as Ledger
  30 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  31 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  32 import qualified Hcompta.Lib.Leijen as W
  33 import           Hcompta.Lib.Consable (Consable(..))
  34
  35 data Ctx
  36  =   Ctx
  37  { ctx_input              :: [FilePath]
  38  } deriving (Show)
  39
  40 nil :: Ctx
  41 nil =
  42         Ctx
  43          { ctx_input = []
  44          }
  45
  46 usage :: IO String
  47 usage = do
  48         bin <- Env.getProgName
  49         let pad = replicate (length bin) ' '
  50         return $unlines $
  51                 [ "SYNTAX "
  52                 , "  "++bin++" stats [-i JOURNAL_FILE]"
  53                 , "  "++pad++"       [JOURNAL_FILE] [...]"
  54                 , ""
  55                 , usageInfo "OPTIONS" options
  56                 ]
  57
  58 options :: Args.Options Ctx
  59 options =
  60         [ Option "h" ["help"]
  61          (NoArg (\_context _ctx -> do
  62                 usage >>= IO.hPutStr IO.stderr
  63                 exitSuccess))
  64          "show this help"
  65         , Option "i" ["input"]
  66          (ReqArg (\s _context ctx -> do
  67                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  68          "read data from given file, multiple uses merge the data as would a concatenation do"
  69         ]
  70
  71 run :: Context.Context -> [String] -> IO ()
  72 run context args = do
  73         (ctx, inputs) <- Args.parse context usage options (nil, args)
  74         read_journals <-
  75                 liftM Data.Either.partitionEithers $ do
  76                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
  77                 >>= do
  78                         mapM $ \path -> do
  79                                 liftIO $ runExceptT $ Ledger.Read.file
  80                                  (Ledger.Read.context () Ledger.journal)
  81                                  path
  82                                 >>= \x -> case x of
  83                                  Left  ko -> return $ Left (path, ko)
  84                                  Right ok -> return $ Right ok
  85         case read_journals of
  86          (errs@(_:_), _journals) ->
  87                 forM_ errs $ \(_path, err) -> do
  88                         Write.fatal context $ err
  89          ([], journals) -> do
  90                 let files = ledger_journals ctx journals
  91                 style_color <- Write.with_color context IO.stdout
  92                 W.displayIO IO.stdout $ do
  93                 W.renderPretty style_color 1.0 maxBound $ do
  94                 doc_journals context ctx files
  95
  96 newtype Journals t = Journals ()
  97  deriving (Show)
  98 instance Monoid (Journals t) where
  99         mempty = Journals ()
 100         mappend _ _ = mempty
 101
 102 instance Consable () Journals t where
 103         mcons () _t !_js = mempty
 104
 105 ledger_journals
 106  :: Ctx
 107  -> [ Ledger.Journal (Journals Ledger.Transaction) ]
 108  -> [FilePath]
 109 ledger_journals _ctx =
 110         Data.Foldable.foldl'
 111          (flip $ Ledger.Journal.fold
 112                  (\Ledger.Journal{Ledger.journal_file=f} ->
 113                         mappend [f]))
 114          mempty
 115
 116 doc_journals
 117  :: Context
 118  -> Ctx
 119  -> [FilePath]
 120  -> W.Doc
 121 doc_journals _context _ctx =
 122         foldr
 123          (\file doc -> doc <> W.toDoc () file <> W.line)
 124          W.empty