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 ((++))
  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 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
 111 instance Consable () Journals t where
 112         mcons () _t !_js = mempty
 113
 114 ledger_journals
 115  :: Ctx
 116  -> [ Ledger.Journal (Journals (Chart, Ledger.Transaction)) ]
 117  -> [FilePath]
 118 ledger_journals _ctx =
 119         Data.Foldable.foldl'
 120          (flip $ Ledger.Journal.fold
 121                  (\Ledger.Journal{Ledger.journal_file=f} ->
 122                         mappend [f]))
 123          mempty
 124
 125 doc_journals
 126  :: C.Context
 127  -> Ctx
 128  -> [FilePath]
 129  -> W.Doc
 130 doc_journals _context _ctx =
 131         foldr
 132          (\file doc -> doc <> W.toDoc () file <> W.line)
 133          W.empty