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