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.DeepSeq (NFData(..))
  11 import           Control.Monad (Monad(..), forM_, liftM, mapM)
  12 import           Control.Monad.IO.Class (liftIO)
  13 import           Control.Monad.Trans.Except (runExceptT)
  14 import           Data.Either (Either(..), partitionEithers)
  15 import           Data.Foldable (Foldable(..))
  16 import           Data.List ((++))
  17 import           Data.Monoid (Monoid(..), (<>))
  18 import           Data.String (String)
  19 import           Text.Show (Show)
  20 import           Prelude (($), Bounded(..), FilePath, IO, flip, unlines)
  21 import           System.Console.GetOpt
  22                   ( ArgDescr(..)
  23                   , OptDescr(..)
  24                   , usageInfo )
  25 import           System.Environment as Env (getProgName)
  26 import           System.Exit (exitSuccess)
  27 import qualified System.IO as IO
  28
  29 import qualified Hcompta.CLI.Args as Args
  30 import qualified Hcompta.CLI.Context as C
  31 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  32 import qualified Hcompta.CLI.Lang as Lang
  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 :: C.Context -> IO String
  52 usage c = do
  53         bin <- Env.getProgName
  54         return $ unlines $
  55                 [ C.translate c Lang.Section_Description
  56                 , "  "++C.translate c Lang.Help_Command_Journals
  57                 , ""
  58                 , C.translate c Lang.Section_Syntax
  59                 , "  "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
  60                                       " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  61                 , ""
  62                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  63                 ]
  64
  65 options :: C.Context -> Args.Options Ctx
  66 options c =
  67         [ Option "h" ["help"]
  68          (NoArg (\_ctx -> do
  69                 usage c >>= IO.hPutStr IO.stderr
  70                 exitSuccess)) $
  71                 C.translate c Lang.Help_Option_Help
  72         , Option "i" ["input"]
  73          (ReqArg (\s ctx -> do
  74                 return $ ctx{ctx_input=s:ctx_input ctx}) $
  75                 C.translate c Lang.Type_File_Journal) $
  76                 C.translate c Lang.Help_Option_Input
  77         ]
  78
  79 run :: C.Context -> [String] -> IO ()
  80 run c args = do
  81         (ctx, inputs) <-
  82                 Args.parse c usage options (nil, args)
  83         read_journals <-
  84                 liftM Data.Either.partitionEithers $ do
  85                 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
  86                 >>= do
  87                         mapM $ \path -> do
  88                                 liftIO $ runExceptT $ Ledger.Read.file
  89                                  (Ledger.Read.context () Ledger.journal)
  90                                  path
  91                                 >>= \x -> case x of
  92                                  Left  ko -> return $ Left (path, ko)
  93                                  Right ok -> return $ Right ok
  94         case read_journals of
  95          (errs@(_:_), _journals) ->
  96                 forM_ errs $ \(_path, err) -> do
  97                         Write.fatal c $ err
  98          ([], journals) -> do
  99                 let files = ledger_journals ctx journals
 100                 style_color <- Write.with_color c IO.stdout
 101                 W.displayIO IO.stdout $ do
 102                 W.renderPretty style_color 1.0 maxBound $ do
 103                 doc_journals c ctx files
 104
 105 newtype Journals t = Journals ()
 106  deriving (Show)
 107 instance Monoid (Journals t) where
 108         mempty = Journals ()
 109         mappend _ _ = mempty
 110 instance NFData t => NFData (Journals t) where
 111         rnf (Journals t) = rnf t
 112
 113 instance Consable () Journals t where
 114         mcons () _t !_js = mempty
 115
 116 ledger_journals
 117  :: Ctx
 118  -> [Ledger.Journal (Journals (Ledger.Chart_With Ledger.Transaction))]
 119  -> [FilePath]
 120 ledger_journals _ctx =
 121         Data.Foldable.foldl'
 122          (flip $ Ledger.Journal.fold
 123                  (\Ledger.Journal{Ledger.journal_file=f} ->
 124                         mappend [f]))
 125          mempty
 126
 127 doc_journals
 128  :: C.Context
 129  -> Ctx
 130  -> [FilePath]
 131  -> W.Doc
 132 doc_journals _context _ctx =
 133         foldr
 134          (\file doc -> doc <> W.toDoc () file <> W.line)
 135          W.empty