+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Command.Journal where
-import Prelude hiding (foldr)
--- import Control.Arrow (first)
--- import Control.Applicative ((<$>))
--- import Control.Monad ((>=>))
+import Control.Arrow ((+++))
+import Control.Monad (Monad(..), liftM, mapM)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (runExceptT)
-import qualified Data.Either
-import Data.Functor.Compose (Compose(..))
-import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
-import Data.Foldable (foldr)
+import Data.Bool
+import Data.Either (Either(..), partitionEithers)
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), on)
+import Data.Functor (Functor(..), (<$>))
+import Data.List ((++))
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.String (String)
+import Prelude (Bounded(..), unlines)
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
, usageInfo )
import System.Environment as Env (getProgName)
-import System.Exit (exitWith, ExitCode(..))
+import System.Exit (exitSuccess)
import qualified System.IO as IO
+import System.IO (FilePath, IO)
import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as Context
-import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Context as C
+import qualified Hcompta.CLI.Env as CLI.Env
+import qualified Hcompta.CLI.Format as Format
+import Hcompta.CLI.Format.JCC ()
+import Hcompta.CLI.Format.Ledger ()
+import Hcompta.CLI.Format (Format(..), Formats)
+import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
-import qualified Hcompta.Format.Ledger.Write as Ledger.Write
-import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.Chart as Chart
+import qualified Hcompta.Posting as Posting
import qualified Hcompta.Filter as Filter
+import qualified Hcompta.Filter.Amount as Filter.Amount
import qualified Hcompta.Filter.Read as Filter.Read
+import qualified Hcompta.Format.JCC as JCC
+import qualified Hcompta.Format.JCC.Write as JCC.Write
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Write as Ledger
+import qualified Hcompta.Journal as Journal
+-- import Hcompta.Lib.Consable (Consable(..))
+import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.Lib.Parsec as R
-data Ctx
- = Ctx
+data Context
+ = Context
{ ctx_input :: [FilePath]
+ , ctx_input_format :: Formats
+ , ctx_output :: [(Write.Mode, FilePath)]
+ , ctx_output_format :: Maybe Formats
, ctx_align :: Bool
- , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
- } deriving (Show)
-
-nil :: Ctx
-nil =
- Ctx
- { ctx_input = []
- , ctx_align = True
- , ctx_transaction_filter = Filter.Any
+ , ctx_reduce_date :: Bool
+ , ctx_filter_transaction :: forall t.
+ ( Filter.Transaction t
+ , Filter.Amount_Quantity
+ (Posting.Posting_Amount
+ (Filter.Transaction_Posting t))
+ ~ Filter.Amount.Quantity
+ ) => Journal_Filter t
+ }
+
+context :: Context
+context =
+ Context
+ { ctx_input = []
+ , ctx_input_format = mempty
+ , ctx_output = []
+ , ctx_output_format = Nothing
+ , ctx_align = True
+ , ctx_reduce_date = True
+ , ctx_filter_transaction = Filter.Simplified $ Right True
}
-usage :: IO String
-usage = do
+usage :: C.Context -> IO String
+usage c = do
bin <- Env.getProgName
- return $unlines $
- [ "SYNTAX "
- , " "++bin++" journal [-t TRANSACTION_FILTER]"
+ return $ unlines $
+ [ C.translate c Lang.Section_Description
+ , " "++C.translate c Lang.Help_Command_Journal
, ""
- , usageInfo "OPTIONS" options
+ , C.translate c Lang.Section_Syntax
+ , " "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
+ " ["++C.translate c Lang.Type_File_Journal++"] [...]"
+ , ""
+ , usageInfo (C.translate c Lang.Section_Options) (options c)
]
-options :: Args.Options Ctx
-options =
+options :: C.Context -> Args.Options Context
+options c =
[ Option "h" ["help"]
- (NoArg (\_context _ctx -> do
- usage >>= IO.hPutStr IO.stderr
- exitWith ExitSuccess))
- "show this help"
+ (NoArg (\_ctx -> do
+ usage c >>= IO.hPutStr IO.stderr
+ exitSuccess)) $
+ C.translate c Lang.Help_Option_Help
, Option "i" ["input"]
- (ReqArg (\s _context ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
- "read data from given file, multiple uses merge the data as would a concatenation do"
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_input=s:ctx_input ctx}) $
+ C.translate c Lang.Type_File_Journal) $
+ C.translate c Lang.Help_Option_Input
+ , Option "if" ["input-format"]
+ (OptArg (\arg ctx -> do
+ ctx_input_format <- case arg of
+ Nothing -> return $ Format_JCC ()
+ Just "jcc" -> return $ Format_JCC ()
+ Just "ledger" -> return $ Format_Ledger ()
+ Just _ -> Write.fatal c $
+ W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_input_format})
+ "[jcc|ledger]")
+ "input format"
+ , Option "o" ["output"]
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
+ C.translate c Lang.Type_File) $
+ C.translate c Lang.Help_Option_Output
+ , Option "of" ["output-format"]
+ (OptArg (\arg ctx -> do
+ ctx_output_format <- case arg of
+ Nothing -> return $ Just $ Format_JCC ()
+ Just "jcc" -> return $ Just $ Format_JCC ()
+ Just "ledger" -> return $ Just $ Format_Ledger ()
+ Just _ -> Write.fatal c $
+ W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_output_format})
+ "[jcc|ledger]")
+ "input format"
+ , Option "O" ["overwrite"]
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
+ C.translate c Lang.Type_File) $
+ C.translate c Lang.Help_Option_Overwrite
, Option "" ["align"]
- (OptArg (\arg context ctx -> do
+ (OptArg (\arg ctx -> do
ctx_align <- case arg of
Nothing -> return $ True
Just "yes" -> return $ True
Just "no" -> return $ False
- Just _ -> Write.fatal context $
+ Just _ -> Write.fatal c $
W.text "--align option expects \"yes\", or \"no\" as value"
return $ ctx{ctx_align})
"[yes|no]")
"align output"
- , Option "t" ["transaction-filter"]
- (ReqArg (\s context ctx -> do
- ctx_transaction_filter <-
- fmap (Filter.And $ ctx_transaction_filter ctx) $
- liftIO $ Filter.Read.read Filter.Read.test_transaction s
- >>= \f -> case f of
- Left ko -> Write.fatal context $ ko
- Right ok -> return ok
- return $ ctx{ctx_transaction_filter}) "FILTER")
- "filter at transaction level, multiple uses are merged with a logical and"
+ {- NOTE: not used so far.
+ , Option "" ["reduce-date"]
+ (OptArg (\arg ctx -> do
+ ctx_reduce_date <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal c $
+ W.text "--reduce-date option expects \"yes\", or \"no\" as value"
+ return $ ctx{ctx_reduce_date})
+ "[yes|no]")
+ "use advanced date reducer to speed up filtering"
+ -}
+ , Option "t" ["filter-transaction"]
+ (ReqArg (\s ctx -> do
+ filter <-
+ R.runParserT_with_Error
+ Filter.Read.filter_transaction
+ Filter.Read.context "" s
+ case filter of
+ Left ko -> Write.fatal c ko
+ Right flt ->
+ return $
+ ctx{ctx_filter_transaction =
+ Filter.and (ctx_filter_transaction ctx) $
+ (Filter.simplify $
+ Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
+ }) $
+ C.translate c Lang.Type_Filter_Transaction) $
+ C.translate c Lang.Help_Option_Filter_Transaction
]
-run :: Context.Context -> [String] -> IO ()
-run context args = do
- (ctx, _args) <- Args.parse context usage options (nil, args)
- read_journals <- do
- CLI.Ledger.paths context $ ctx_input ctx
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- >>= return . Data.Either.partitionEithers
- case read_journals of
- (errs@(_:_), _journals) ->
- (flip mapM_) errs $ \(_path, err) -> do
- Write.fatal context $ err
- ([], journals) -> do
- Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
- style_color <- Write.with_color context IO.stdout
- let sty = Ledger.Write.Style
- { Ledger.Write.style_align = ctx_align ctx
- , Ledger.Write.style_color
- }
- let transactions =
- foldr
- (Ledger.Journal.fold
- (\j ->
- let ts = Ledger.journal_transactions j in
- Data.Map.unionWith (++) $
- case ctx_transaction_filter ctx of
- Filter.Any -> ts
- _ ->
- Data.Map.mapMaybe
- (\lt ->
- case Data.List.filter
- (Filter.test (ctx_transaction_filter ctx)) lt of
- [] -> Nothing
- l -> Just l
- )
- ts
- ))
- Data.Map.empty
- journals
- Ledger.Write.put sty IO.stdout $ do
- Ledger.Write.transactions (Compose transactions)
+run :: C.Context -> [String] -> IO ()
+run c args = do
+ (ctx, inputs) <- Args.parse c usage options (context, args)
+ input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
+ read_journals <- mapM (liftIO . journal_read ctx) input_paths
+ case partitionEithers read_journals of
+ (errs@(_:_), _journals) -> Write.fatals c errs
+ ([], (journals::[Forall_Journal])) -> do
+ with_color <- Write.with_color c IO.stdout
+ W.displayIO IO.stdout $
+ W.renderPretty with_color 1.0 maxBound $
+ journal_write $ mconcat $
+ Format.journal_flatten <$>
+ case ctx_output_format ctx of
+ Nothing -> journals
+ Just f -> Format.journal_empty f:journals
+
+-- * Type 'Format_Journal'
+
+type Format_Journal
+ = Format
+ ( JCC.Journal Journal_JCC)
+ (Ledger.Journal Journal_Ledger)
+
+type Journal_JCC = Journal.Journal ( JCC.Charted JCC.Transaction)
+type Journal_Ledger = Journal.Journal (Ledger.Charted Ledger.Transaction)
+
+-- * Class 'Journal'
+
+class Journal j where
+ journal_write :: j -> W.Doc
+
+instance Format.Journal (JCC.Journal Journal_JCC) where
+ type Journal_Format (JCC.Journal Journal_JCC) = Format_Journal
+ journal_format = Format_JCC
+instance Journal (JCC.Journal Journal_JCC) where
+ journal_write j =
+ JCC.Write.transactions (JCC.journal_amount_styles j) $
+ fmap Chart.charted $
+ JCC.journal_content j
+
+instance Format.Journal (Ledger.Journal Journal_Ledger) where
+ type Journal_Format (Ledger.Journal Journal_Ledger) = Format_Journal
+ journal_format = Format_Ledger
+instance Journal (Ledger.Journal Journal_Ledger) where
+ journal_write j =
+ Ledger.write_transactions (Ledger.journal_amount_styles j) $
+ fmap Chart.charted $
+ Ledger.journal_content j
+
+-- * Type 'Forall_Journal'
+
+data Forall_Journal
+ = forall j m. ( Journal (j m)
+ , Format.Journal (j m)
+ , Format.Journal_Read j
+ , Format.Journal_Monoid (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal )
+ => Forall_Journal (j m)
+
+instance Format.Journal Forall_Journal where
+ type Journal_Format Forall_Journal = Format_Journal
+ journal_format (Forall_Journal j) = Format.journal_format j
+instance Format.Journal_Empty Forall_Journal where
+ journal_empty f =
+ case f of
+ Format_JCC () -> Forall_Journal (mempty::JCC.Journal Journal_JCC)
+ Format_Ledger () -> Forall_Journal (mempty::Ledger.Journal Journal_Ledger)
+
+instance Format.Journal_Monoid Forall_Journal where
+ journal_flatten (Forall_Journal j) = Forall_Journal $ Format.journal_flatten j
+ journal_fold f (Forall_Journal j) = Format.journal_fold (f . Forall_Journal) j
+instance Journal Forall_Journal where
+ journal_write (Forall_Journal j) = journal_write j
+instance Monoid Forall_Journal where
+ mempty = Forall_Journal (mempty::JCC.Journal Journal_JCC)
+ mappend x y =
+ case (mappend `on` Format.journal_format) x y of
+ Format_JCC j -> Forall_Journal j
+ Format_Ledger j -> Forall_Journal j
+ mconcat js =
+ case js of
+ [] -> mempty
+ j:jn -> foldl' mappend j jn
+
+type Journal_Filter transaction
+ = Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction transaction))
+type Journal_Read_Cons txn
+ = txn -> Filter.Filtered (Journal_Filter txn) txn
+
+journal_read
+ :: Context -> FilePath
+ -> IO (Either (Format.Message W.Doc) Forall_Journal)
+journal_read ctx =
+ case ctx_input_format ctx of
+ Format_JCC () ->
+ let wrap (j::JCC.Journal Journal_JCC) = Forall_Journal j in
+ let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+ Format_Ledger () ->
+ let wrap (j::Ledger.Journal Journal_Ledger) = Forall_Journal j in
+ let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
sourcephile / git / comptalang.git / blobdiff