{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# 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.Journals where
-import Control.Monad (Monad(..), forM_, liftM, mapM)
+import Control.Arrow ((+++))
+import Control.Monad (Monad(..), liftM, mapM)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (runExceptT)
import Data.Either (Either(..), partitionEithers)
import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), const)
import Data.List ((++))
+import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..), (<>))
import Data.String (String)
-import Text.Show (Show)
-import Prelude (($), Bounded(..), FilePath, IO, flip, unlines)
+import Prelude (Bounded(..), FilePath, IO, unlines)
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
, usageInfo )
-import System.Environment as Env (getProgName)
+import qualified System.Environment as Env
import System.Exit (exitSuccess)
import qualified System.IO as IO
+import Text.Show (Show)
-import Hcompta.Chart (Chart)
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Env as CLI.Env
+import qualified Hcompta.CLI.Format as Format
+import Hcompta.CLI.Format (Format(..), Formats)
+import Hcompta.CLI.Format.Ledger ()
+import Hcompta.CLI.Format.JCC ()
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
+-- import qualified Hcompta.Lib.Parsec as R
+import qualified Hcompta.Format.JCC as JCC
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 Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Leijen as W
-data Ctx
- = Ctx
- { ctx_input :: [FilePath]
+data Context
+ = Context
+ { ctx_input :: [FilePath]
+ , ctx_input_format :: Formats
} deriving (Show)
-nil :: Ctx
-nil =
- Ctx
- { ctx_input = []
+context :: Context
+context =
+ Context
+ { ctx_input = []
+ , ctx_input_format = mempty
}
usage :: C.Context -> IO String
, usageInfo (C.translate c Lang.Section_Options) (options c)
]
-options :: C.Context -> Args.Options Ctx
+options :: C.Context -> Args.Options Context
options c =
[ Option "h" ["help"]
(NoArg (\_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"
]
run :: C.Context -> [String] -> IO ()
run c args = do
- (ctx, inputs) <-
- Args.parse c usage options (nil, args)
- read_journals <-
- liftM Data.Either.partitionEithers $ do
- CLI.Ledger.paths c $ ctx_input ctx ++ inputs
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file
- (Ledger.Read.context () Ledger.journal)
- path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- case read_journals of
- (errs@(_:_), _journals) ->
- forM_ errs $ \(_path, err) -> do
- Write.fatal c $ err
+ (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) -> do
- let files = ledger_journals ctx journals
- style_color <- Write.with_color c IO.stdout
+ with_color <- Write.with_color c IO.stdout
W.displayIO IO.stdout $ do
- W.renderPretty style_color 1.0 maxBound $ do
- doc_journals c ctx files
+ W.renderPretty with_color 1.0 maxBound $
+ W.toDoc () $
+ mconcat journals
+
+-- * Class 'Journal'
+
+class
+ ( Format.Journal_Monoid (j m)
+ , Format.Journal_Read j
+ ) => Journal j m where
+ journal_files :: j m -> [FilePath]
+
+-- JCC
+instance Journal JCC.Journal Journals_JCC where
+ journal_files j = [JCC.journal_file j]
-newtype Journals t = Journals ()
+-- Ledger
+instance Journal Ledger.Journal Journals_Ledger where
+ journal_files = Ledger.journal_files
+
+type Journals_JCC = ()
+type Journals_Ledger = ()
+
+-- * Type 'Journals'
+
+newtype Journals =
+ Journals [FilePath]
deriving (Show)
-instance Monoid (Journals t) where
- mempty = Journals ()
- mappend _ _ = mempty
-
-instance Consable () Journals t where
- mcons () _t !_js = mempty
-
-ledger_journals
- :: Ctx
- -> [ Ledger.Journal (Journals (Chart, Ledger.Transaction)) ]
- -> [FilePath]
-ledger_journals _ctx =
- Data.Foldable.foldl'
- (flip $ Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_file=f} ->
- mappend [f]))
- mempty
-
-doc_journals
- :: C.Context
- -> Ctx
- -> [FilePath]
- -> W.Doc
-doc_journals _context _ctx =
- foldr
- (\file doc -> doc <> W.toDoc () file <> W.line)
- W.empty
+instance Monoid Journals where
+ mempty = Journals []
+ mappend (Journals x) (Journals y) =
+ Journals (mappend x y)
+ mconcat = foldl' mappend mempty
+instance W.ToDoc () Journals where
+ toDoc () (Journals files) =
+ foldr
+ (\file doc -> doc <> W.toDoc () file <> W.line)
+ W.empty files
+
+type Journal_Read_Cons txn = txn -> ()
+journal_read
+ :: Context -> FilePath
+ -> IO (Either (Format.Message W.Doc) Journals)
+journal_read ctx =
+ case ctx_input_format ctx of
+ Format_JCC () ->
+ let wrap (j::JCC.Journal Journals_JCC) =
+ Format.journal_fold journals_cons j mempty in
+ let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
+ = const () in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+ Format_Ledger () ->
+ let wrap (j::Ledger.Journal Journals_Ledger) =
+ Format.journal_fold journals_cons j mempty in
+ let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
+ = const () in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+
+journals_cons :: Journal j m => j m -> Journals -> Journals
+journals_cons j !(Journals files) =
+ Journals (journal_files j ++ files)
sourcephile / git / comptalang.git / blobdiff