cli/Hcompta/CLI/Command/Print.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 module Hcompta.CLI.Command.Print where
   3
   4 import           Control.Arrow (first)
   5 import           Control.Applicative ((<$>))
   6 import           Control.Monad.IO.Class (liftIO)
   7 import           Control.Monad.Trans.Except (runExceptT)
   8 import qualified Data.Either
   9 import qualified Data.List
  10 import qualified Data.Map.Strict as Data.Map
  11 import qualified Data.Text.Lazy as TL
  12 import           System.Console.GetOpt
  13                  ( ArgDescr(..)
  14                  , OptDescr(..)
  15                  , usageInfo )
  16 import           System.Environment as Env (getProgName)
  17 import           System.Exit (exitWith, ExitCode(..))
  18 import qualified System.IO as IO
  19
  20 import qualified Hcompta.CLI.Args as Args
  21 import qualified Hcompta.CLI.Context as Context
  22 import qualified Hcompta.CLI.Write as Write
  23 import qualified Hcompta.Calc.Balance as Balance
  24 import qualified Hcompta.Format.Ledger.Balance as Ledger.Balance
  25 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  26 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  27 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  28 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  29 import qualified Hcompta.Model.Journal
  30 import qualified Hcompta.Model.Transaction as Transaction
  31
  32 data Ctx
  33  =   Ctx
  34  { ctx_input :: [FilePath]
  35  } deriving (Eq, Show)
  36
  37 nil :: Ctx
  38 nil =
  39         Ctx
  40          { ctx_input = []
  41          }
  42
  43 usage :: IO String
  44 usage = do
  45         bin <- Env.getProgName
  46         return $unlines $
  47                 [ "SYNTAX "
  48                 , "  "++bin++" print [option..]"
  49                 , ""
  50                 , usageInfo "OPTIONS" options
  51                 ]
  52
  53 options :: Args.Options Ctx
  54 options =
  55         [ Option "h" ["help"]
  56          (NoArg (\_ctx -> do
  57                 usage >>= IO.hPutStr IO.stderr
  58                 exitWith ExitSuccess))
  59          "show this help"
  60         , Option "i" ["input"]
  61          (ReqArg (\s ctx -> do
  62                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  63          "read data from given file"
  64         ]
  65
  66 run :: Context.Context -> [String] -> IO ()
  67 run context args = do
  68         (ctx, _) <-
  69                 first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
  70                 Args.parse context usage options (nil, args)
  71         (flip mapM) (ctx_input ctx) $ \path -> do
  72                 liftIO $ runExceptT $
  73                         Ledger.Read.file path
  74                 >>= \x -> case x of
  75                  Left  ko -> return $ Left (path, ko)
  76                  Right ok -> return $ Right ok
  77         >>= return . Data.Either.partitionEithers
  78         >>= \x -> case x of
  79          (kos@(_:_), _oks) ->
  80                 (flip mapM_) kos $ \(_path, ko) -> Write.fatal context ko
  81          ([], journals) -> do
  82                 with_color <- Write.with_color context IO.stdout
  83                 case Lib.Foldable.find Ledger.Balance.equilibre journals of
  84                  Just ((tr, eq), path) ->
  85                         Write.fatal context $ concat
  86                          [ "the following transaction is not equilibrated, because:"
  87                          , case eq of
  88                                  Balance.Equilibre e | not $ Balance.is_equilibrable eq ->
  89                                         concat $ Data.Map.elems $ Data.Map.mapWithKey
  90                                          (\unit Balance.Unit_Sum{Balance.amount} -> concat
  91                                                 [ "\n- unit \""
  92                                                 , TL.unpack $ Ledger.Write.show with_color $ Ledger.Write.unit unit
  93                                                 , "\" sums up to the non-null amount: "
  94                                                 , TL.unpack $ Ledger.Write.show with_color $ Ledger.Write.amount amount
  95                                                 ])
  96                                          e
  97                                  _ -> ""
  98                          , "\nin ", show $ Transaction.sourcepos tr
  99                          , concat $ map (\j -> "\nincluded by \"" ++ Ledger.Journal.file j ++ "\"") path
 100                          , ":\n", TL.unpack $ Ledger.Write.show with_color $
 101                                 Ledger.Write.transaction tr
 102                          ]
 103                  Nothing -> do
 104                         let journal
 105                                 = Hcompta.Model.Journal.unions $
 106                                 Data.List.map Ledger.Journal.to_Model journals
 107                         Ledger.Write.put with_color IO.stdout $ do
 108                         Ledger.Write.journal journal