cli/Hcompta/CLI/Command/Journals.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE Rank2Types #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE TupleSections #-}
  11 {-# LANGUAGE TypeFamilies #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 module Hcompta.CLI.Command.Journals where
  14
  15 import           Control.Arrow ((+++))
  16 import           Control.Monad (Monad(..), mapM)
  17 import           Control.Monad.IO.Class (liftIO)
  18 import           Data.Either (Either(..), partitionEithers)
  19 import           Data.Foldable (Foldable(..))
  20 import           Data.Function (($), (.), const)
  21 import           Data.Functor ((<$>))
  22 import           Data.List ((++))
  23 import           Data.Maybe (Maybe(..))
  24 import           Data.Monoid (Monoid(..), (<>))
  25 import           Data.String (String)
  26 import           Prelude (Bounded(..), FilePath, IO, unlines)
  27 import           System.Console.GetOpt
  28                   ( ArgDescr(..)
  29                   , OptDescr(..)
  30                   , usageInfo )
  31 import qualified System.Environment as Env
  32 import           System.Exit (exitSuccess)
  33 import qualified System.IO as IO
  34 import           Text.Show (Show)
  35
  36 import qualified Hcompta.CLI.Args as Args
  37 import qualified Hcompta.CLI.Context as C
  38 import qualified Hcompta.CLI.Env as CLI.Env
  39
  40 import qualified Hcompta.CLI.Format as Format
  41 import           Hcompta.CLI.Format (Format(..), Formats)
  42 import           Hcompta.CLI.Format.Ledger ()
  43 import           Hcompta.CLI.Format.JCC ()
  44 import qualified Hcompta.CLI.Lang as Lang
  45 import qualified Hcompta.CLI.Write as Write
  46
  47
  48 -- import qualified Hcompta.Lib.Parsec as R
  49 import qualified Hcompta.JCC as JCC
  50 import qualified Hcompta.Ledger as Ledger
  51 import qualified Text.WalderLeijen.ANSI.Text as W
  52
  53 data Context
  54  =   Context
  55  { ctx_input        :: [FilePath]
  56  , ctx_input_format :: Formats
  57  } deriving (Show)
  58
  59 context :: Context
  60 context =
  61         Context
  62          { ctx_input        = []
  63          , ctx_input_format = mempty
  64          }
  65
  66 usage :: C.Context -> IO String
  67 usage c = do
  68         bin <- Env.getProgName
  69         return $ unlines $
  70                 [ C.translate c Lang.Section_Description
  71                 , "  "++C.translate c Lang.Help_Command_Journals
  72                 , ""
  73                 , C.translate c Lang.Section_Syntax
  74                 , "  "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
  75                                       " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  76                 , ""
  77                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  78                 ]
  79
  80 options :: C.Context -> Args.Options Context
  81 options c =
  82         [ Option "h" ["help"]
  83          (NoArg (\_ctx -> do
  84                 usage c >>= IO.hPutStr IO.stderr
  85                 exitSuccess)) $
  86                 C.translate c Lang.Help_Option_Help
  87         , Option "i" ["input"]
  88          (ReqArg (\s ctx ->
  89                 return $ ctx{ctx_input=s:ctx_input ctx}) $
  90                 C.translate c Lang.Type_File_Journal) $
  91                 C.translate c Lang.Help_Option_Input
  92         , Option "f" ["input-format"]
  93          (OptArg (\arg ctx -> do
  94                 ctx_input_format <- case arg of
  95                  Nothing       -> return $ Format_JCC ()
  96                  Just "jcc"    -> return $ Format_JCC ()
  97                  Just "ledger" -> return $ Format_Ledger ()
  98                  Just _        -> Write.fatal c $
  99                         W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
 100                 return $ ctx{ctx_input_format})
 101           "[jcc|ledger]")
 102           "input format"
 103         ]
 104
 105 run :: C.Context -> [String] -> IO ()
 106 run c args = do
 107         (ctx, inputs) <- Args.parse c usage options (context, args)
 108         input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
 109         read_journals <- mapM (liftIO . journal_read ctx) input_paths
 110         case partitionEithers read_journals of
 111          (errs@(_:_), _journals) -> Write.fatals c errs
 112          ([], journals) -> do
 113                 with_color <- Write.with_color c IO.stdout
 114                 W.displayIO IO.stdout $
 115                         W.renderPretty with_color 1.0 maxBound $
 116                                 W.toDoc () $
 117                                 mconcat journals
 118
 119 -- * Class 'Journal'
 120
 121 class
 122  ( Format.Journal_Monoid (j m)
 123  , Format.Journal_Read j
 124  ) => Journal j m where
 125         journal_files :: j m -> [FilePath]
 126
 127 -- JCC
 128 instance Journal JCC.Journal Journals_JCC where
 129         journal_files = JCC.journal_files
 130
 131 -- Ledger
 132 instance Journal Ledger.Journal Journals_Ledger where
 133         journal_files = Ledger.journal_files
 134
 135 type Journals_JCC    = ()
 136 type Journals_Ledger = ()
 137
 138 -- * Type 'Journals'
 139
 140 newtype Journals =
 141         Journals [FilePath]
 142  deriving (Show)
 143 instance Monoid Journals where
 144         mempty = Journals []
 145         mappend (Journals x) (Journals y) =
 146                 Journals (mappend x y)
 147         mconcat = foldl' mappend mempty
 148 instance W.ToDoc () Journals where
 149         toDoc () (Journals files) =
 150                 foldr
 151                  (\file doc -> doc <> W.toDoc () file <> W.line)
 152                  W.empty files
 153
 154 type Journal_Read_Cons txn = txn -> ()
 155 journal_read
 156  :: Context -> FilePath
 157  -> IO (Either (Format.Message W.Doc) Journals)
 158 journal_read ctx =
 159         case ctx_input_format ctx of
 160          Format_JCC () ->
 161                 let wrap (j::JCC.Journal Journals_JCC) =
 162                         Format.journal_fold journals_cons j mempty in
 163                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 164                          = const () in
 165                 (((+++) Format.Message wrap) <$>) .
 166                 Format.journal_read cons
 167          Format_Ledger () ->
 168                 let wrap (j::Ledger.Journal Journals_Ledger) =
 169                         Format.journal_fold journals_cons j mempty in
 170                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 171                          = const () in
 172                 (((+++) Format.Message wrap) <$>) .
 173                 Format.journal_read cons
 174
 175 journals_cons :: Journal j m => j m -> Journals -> Journals
 176 journals_cons j (Journals files) =
 177         Journals (journal_files j ++ files)