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