cli/Hcompta/CLI/Command/Journals.hs

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