cli/Hcompta/CLI/Command/Print.hs

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