--- /dev/null
+import "hint" HLint.HLint
+ignore "Redundant $"
+ignore "Redundant bracket"
+ignore "Use ++"
+ignore "Use String"
+ignore "Use camelCase"
+ignore "Use import/export shortcut"
+ignore "Use second"
+++ /dev/null
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Format.Ledger
- ( module Hcompta.Format.Ledger.Account
- , module Hcompta.Format.Ledger.Amount
- , module Hcompta.Format.Ledger.Chart
- , module Hcompta.Format.Ledger.Posting
- , module Hcompta.Format.Ledger.Transaction
- , module Hcompta.Format.Ledger.Journal
- ) where
-
-
-import Hcompta.Format.Ledger.Account
-import Hcompta.Format.Ledger.Amount
-import Hcompta.Format.Ledger.Chart
-import Hcompta.Format.Ledger.Posting
-import Hcompta.Format.Ledger.Transaction
-import Hcompta.Format.Ledger.Journal
+++ /dev/null
-module Hcompta.Format.Ledger.Chart where
-
-import qualified Hcompta.Chart as Chart
-import Hcompta.Format.Ledger.Account
-
--- * Type 'Chart'
-
-type Chart = Chart.Chart Account
-type Charted = Chart.Charted Account
+++ /dev/null
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.Format.Ledger.Posting where
-
-import Control.DeepSeq (NFData(..))
-import Data.Bool
-import Data.Data (Data(..))
-import Data.Eq (Eq(..))
-import Data.Function (($), (.), flip)
-import qualified Data.List as List
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.Text (Text)
-import Data.Tuple (uncurry)
-import Data.Typeable (Typeable)
-import Prelude (seq, undefined)
-import Text.Parsec.Pos (SourcePos, initialPos)
-import Text.Show (Show)
-
-import qualified Hcompta.Balance as Balance
-import qualified Hcompta.Chart as Chart
-import Hcompta.Date (Date)
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.GL as GL
-import Hcompta.Lib.Parsec ()
-import qualified Hcompta.Polarize as Polarize
-import Hcompta.Posting (Posting_Tags(..))
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Stats as Stats
-import Hcompta.Tag (Tags(..))
-
-import Hcompta.Format.Ledger.Account
-import Hcompta.Format.Ledger.Amount
-import Hcompta.Format.Ledger.Chart
-
--- * Type 'Posting_Type'
-
-data Posting_Type
- = Posting_Type_Regular
- | Posting_Type_Virtual
- | Posting_Type_Virtual_Balanced
- deriving (Data, Eq, Show, Typeable)
-
-data Posting_Typed posting
- = Posting_Typed Posting_Type posting
- deriving (Data, Eq, Show, Typeable)
-
-posting_type :: Posting -> Posting_Type
-posting_type Posting{posting_tags=Posting_Tags (Tags attrs)} =
- case Map.lookup ("Virtual":|[]) attrs of
- Nothing -> Posting_Type_Regular
- Just l | "Balanced" `List.elem` l -> Posting_Type_Virtual_Balanced
- Just _ -> Posting_Type_Virtual
-
--- * Type 'Comment'
-
-type Comment = Text
-
--- * Type 'Posting'
-
-data Posting
- = Posting
- { posting_account :: Account
- , posting_amounts :: Map Unit Quantity
- , posting_comments :: [Comment]
- , posting_dates :: [Date]
- , posting_sourcepos :: SourcePos
- , posting_status :: Bool
- , posting_tags :: Posting_Tags
- } deriving (Data, Eq, Show, Typeable)
-instance NFData Posting where
- rnf
- Posting
- { posting_account
- , posting_amounts
- , posting_comments
- , posting_dates
- -- , posting_sourcepos
- , posting_status
- , posting_tags
- } =
- rnf posting_account `seq`
- rnf posting_amounts `seq`
- rnf posting_comments `seq`
- rnf posting_dates `seq`
- -- rnf posting_sourcepos `seq`
- rnf posting_status `seq`
- rnf posting_tags
-
-posting :: Account -> Posting
-posting acct =
- Posting
- { posting_account = acct
- , posting_amounts = mempty
- , posting_comments = mempty
- , posting_dates = mempty
- , posting_status = False
- , posting_sourcepos = initialPos ""
- , posting_tags = mempty
- }
-
-postings_by_account :: [Posting] -> Map Account [Posting]
-postings_by_account =
- Map.fromListWith (flip mappend) .
- List.map (\p -> (posting_account p, [p]))
-
-instance Posting.Posting Posting where
- type Posting_Account Posting = Account
- type Posting_Amount Posting = Amount
- type Posting_Amounts Posting = []
- posting_account = posting_account
- posting_amounts = List.map (uncurry Amount) . Map.toList . posting_amounts
-
-instance Posting.Posting (Charted Posting) where
- type Posting_Account (Charted Posting) = Charted Account
- type Posting_Amount (Charted Posting) = Posting.Posting_Amount Posting
- type Posting_Amounts (Charted Posting) = Posting.Posting_Amounts Posting
- posting_account (Chart.Charted c p) = Chart.Charted c $ Posting.posting_account p
- posting_amounts = Posting.posting_amounts . Chart.charted
-
-instance Balance.Posting Posting where
- type Posting_Account Posting = Account
- type Posting_Quantity Posting = Polarize.Polarized Quantity
- type Posting_Unit Posting = Unit
- posting_account = posting_account
- posting_amounts = Map.map Polarize.polarize . posting_amounts
- posting_set_amounts amounts p =
- p { posting_amounts=Map.map Polarize.depolarize amounts }
-
-instance Balance.Posting (Charted Posting) where
- type Posting_Account (Charted Posting) = Account
- type Posting_Quantity (Charted Posting) = Balance.Posting_Quantity Posting
- type Posting_Unit (Charted Posting) = Balance.Posting_Unit Posting
- posting_account = posting_account . Chart.charted
- posting_amounts = Map.map Polarize.polarize . posting_amounts . Chart.charted
- posting_set_amounts amounts (Chart.Charted c p) =
- Chart.Charted c p{ posting_amounts=Map.map Polarize.depolarize amounts }
-
-instance Filter.Posting (Charted Posting) where
- posting_type = undefined
- -- NOTE: the posting_type will be given to Filter.test
- -- through instance Posting p => Posting (Posting_Typed p)
- -- by Filter.transaction_postings
- -- and Filter.transaction_postings_virtual
-
-instance GL.Posting Posting where
- type Posting_Account Posting = Account
- type Posting_Quantity Posting = Map Unit (Polarize.Polarized Quantity)
- posting_account = posting_account
- posting_quantity = Map.map Polarize.polarize . posting_amounts
-
-instance GL.Posting (Charted Posting) where
- type Posting_Account (Charted Posting) = Account
- type Posting_Quantity (Charted Posting) = GL.Posting_Quantity Posting
- posting_account = GL.posting_account . Chart.charted
- posting_quantity = GL.posting_quantity . Chart.charted
-
-instance Stats.Posting Posting where
- type Posting_Account Posting = Account
- type Posting_Quantity Posting = Quantity
- type Posting_Unit Posting = Unit
- posting_account = posting_account
- posting_amounts = posting_amounts
-
-{-
--- ** 'Posting' mappings
-
-type Posting_by_Account
- = Map Account [Posting]
-
-type Posting_by_Amount_and_Account
- = Map (Map Unit Amount) Posting_by_Account
-
-type Posting_by_Signs_and_Account
- = Map Signs Posting_by_Account
-
--- | Return a Data.'Map.Map' associating the given 'Posting's with their respective 'Account'.
-posting_by_Account :: [Posting] -> Posting_by_Account
-posting_by_Account =
- Map.fromListWith (flip mappend) .
- Data.List.map
- (\p -> (posting_account p, [p]))
-
-posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Account
-posting_by_Amount_and_Account =
- Map.foldlWithKey
- (flip (\acct ->
- Data.List.foldl'
- (flip (\p ->
- Map.insertWith
- (Map.unionWith mappend)
- (posting_amounts p)
- (Map.singleton acct [p])))))
- mempty
-
-posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
-posting_by_Signs_and_Account =
- Map.foldlWithKey
- (flip (\acct ->
- Data.List.foldl'
- (flip (\p ->
- Map.insertWith
- (Map.unionWith mappend)
- (signs $ posting_amounts p)
- (Map.singleton acct [p])))))
- mempty
--}
+++ /dev/null
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.Format.Ledger.Transaction where
-
-import Control.DeepSeq (NFData(..))
-import Data.Bool
-import Data.Data (Data(..))
-import Data.Eq (Eq(..))
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..))
-import Data.Functor.Compose (Compose(..))
-import qualified Data.List as List
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.Text (Text)
-import Data.Tuple (fst)
-import Data.Typeable (Typeable)
-import Prelude (flip, seq)
-import Text.Parsec.Pos (SourcePos, initialPos)
-import Text.Show (Show)
-
-import qualified Hcompta.Chart as Chart
-import Hcompta.Date (Date)
-import qualified Hcompta.Date as Date
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.GL as GL
-import qualified Hcompta.Journal as Journal
-import Hcompta.Lib.Parsec ()
-import qualified Hcompta.Stats as Stats
-import Hcompta.Transaction (Transaction_Tags(..))
-
-import Hcompta.Format.Ledger.Account
-import Hcompta.Format.Ledger.Posting
-import Hcompta.Format.Ledger.Chart
-
-type Code = Text
-type Status = Bool
-type Wording = Text
-
--- * Type 'Transaction'
-
-data Transaction
- = Transaction
- { transaction_code :: Code
- , transaction_comments_before :: [Comment]
- , transaction_comments_after :: [Comment]
- , transaction_dates :: (Date, [Date])
- , transaction_postings :: Map Account [Posting]
- , transaction_sourcepos :: SourcePos
- , transaction_status :: Status
- , transaction_tags :: Transaction_Tags
- , transaction_wording :: Wording
- } deriving (Data, Eq, Show, Typeable)
-instance NFData Transaction where
- rnf
- Transaction
- { transaction_code
- , transaction_comments_before
- , transaction_comments_after
- , transaction_dates
- , transaction_postings
- -- , transaction_sourcepos
- , transaction_status
- , transaction_tags
- , transaction_wording
- } =
- rnf transaction_code `seq`
- rnf transaction_comments_before `seq`
- rnf transaction_comments_after `seq`
- rnf transaction_dates `seq`
- rnf transaction_postings `seq`
- -- rnf transaction_sourcepos `seq`
- rnf transaction_status `seq`
- rnf transaction_tags `seq`
- rnf transaction_wording
-
-transaction :: Transaction
-transaction =
- Transaction
- { transaction_code = ""
- , transaction_comments_after = []
- , transaction_comments_before = []
- , transaction_dates = (Date.nil, [])
- , transaction_postings = mempty
- , transaction_sourcepos = initialPos ""
- , transaction_status = False
- , transaction_tags = mempty
- , transaction_wording = ""
- }
-
-instance Filter.Transaction (Charted Transaction) where
- type Transaction_Posting (Charted Transaction) = Charted Posting
- type Transaction_Postings (Charted Transaction) = Compose (Map Account) []
- transaction_date = fst . transaction_dates . Chart.charted
- transaction_wording = transaction_wording . Chart.charted
- transaction_postings (Chart.Charted c t) =
- fmap (Chart.Charted c) $
- Compose $ transaction_postings t
- {-
- transaction_postings_virtual (Chart.Charted c t) =
- fmap (Chart.Charted c) $
- Compose
- [ Compose $ transaction_virtual_postings t
- , Compose $ transaction_balanced_virtual_postings t
- ]
- -}
- transaction_tags = transaction_tags . Chart.charted
-
-instance Journal.Transaction Transaction where
- transaction_date = fst . transaction_dates
-instance Journal.Transaction (Charted Transaction) where
- transaction_date = Journal.transaction_date . Chart.charted
-
-instance Stats.Transaction Transaction where
- type Transaction_Posting Transaction = Posting
- type Transaction_Postings Transaction = Compose (Map Account) []
- transaction_date = fst . transaction_dates
- transaction_postings = Compose . transaction_postings
- transaction_postings_size = Map.size . transaction_postings
- transaction_tags = transaction_tags
-instance Stats.Transaction (Charted Transaction) where
- type Transaction_Posting (Charted Transaction) = Stats.Transaction_Posting Transaction
- type Transaction_Postings (Charted Transaction) = Stats.Transaction_Postings Transaction
- transaction_date = Stats.transaction_date . Chart.charted
- transaction_postings = Stats.transaction_postings . Chart.charted
- transaction_postings_size = Stats.transaction_postings_size . Chart.charted
- transaction_tags = Stats.transaction_tags . Chart.charted
-
-instance GL.Transaction Transaction where
- type Transaction_Line Transaction = Transaction
- type Transaction_Posting Transaction = Posting
- type Transaction_Postings Transaction = Compose (Map Account) []
- transaction_line = id
- transaction_date = fst . transaction_dates
- transaction_postings = Compose . transaction_postings
- transaction_postings_filter f t =
- t{ transaction_postings =
- Map.mapMaybe
- (\p -> case List.filter f p of
- [] -> Nothing
- ps -> Just ps)
- (transaction_postings t)
- }
-instance GL.Transaction (Charted Transaction) where
- type Transaction_Line (Charted Transaction) = Transaction
- type Transaction_Posting (Charted Transaction) = (Charted (GL.Transaction_Posting Transaction))
- type Transaction_Postings (Charted Transaction) = GL.Transaction_Postings Transaction
- transaction_line = Chart.charted
- transaction_date = GL.transaction_date . Chart.charted
- transaction_postings (Chart.Charted c t) =
- fmap (Chart.Charted c) $
- GL.transaction_postings t
- transaction_postings_filter f (Chart.Charted c t) =
- Chart.Charted c
- t{ transaction_postings =
- Map.mapMaybe
- (\p -> case List.filter f $ fmap (Chart.Charted c) p of
- [] -> Nothing
- ps -> Just $ fmap Chart.charted ps)
- (transaction_postings t)
- }
-
--- | Return a 'Map' associating
--- the given 'Transaction's with their respective 'Date'.
-transaction_by_date :: [Transaction] -> (Compose (Map Date) []) Transaction
-transaction_by_date =
- Compose .
- Map.fromListWith (flip mappend) .
- List.map (\t -> (fst $ transaction_dates t, [t]))
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Hcompta.Ledger
+ ( module Hcompta.Ledger.Account
+ , module Hcompta.Ledger.Amount
+ , module Hcompta.Ledger.Chart
+ , module Hcompta.Ledger.Posting
+ , module Hcompta.Ledger.Transaction
+ , module Hcompta.Ledger.Journal
+ , module Hcompta.Ledger.Read
+ , module Hcompta.Ledger.Write
+ ) where
+
+import Hcompta.Ledger.Account
+import Hcompta.Ledger.Amount
+import Hcompta.Ledger.Chart
+import Hcompta.Ledger.Posting
+import Hcompta.Ledger.Transaction
+import Hcompta.Ledger.Journal
+import Hcompta.Ledger.Read
+import Hcompta.Ledger.Write
{-# LANGUAGE DeriveDataTypeable #-}
-module Hcompta.Format.Ledger.Account where
+module Hcompta.Ledger.Account where
import Data.Data (Data(..))
import Data.Eq (Eq(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Data.Typeable (Typeable)
+import Text.Regex.TDFA (Regex)
import Text.Show (Show)
-import Hcompta.Lib.Parsec ()
-import Hcompta.Lib.Regex (Regex)
+-- import qualified Hcompta as H
+import Text.Regex.TDFA.Show ()
-- * Type 'Account'
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Format.Ledger.Amount where
+module Hcompta.Ledger.Amount where
import Control.DeepSeq
import Data.Bool
import Prelude (Int, seq)
import Text.Show (Show(..))
-import qualified Hcompta.Amount as Amount
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Polarize as Polarize
-import qualified Hcompta.Quantity as Quantity
-import qualified Hcompta.Unit as Unit
-
+import qualified Hcompta as H
-- * Type 'Quantity'
-type Quantity = Filter.Amount.Quantity
+type Quantity = Decimal
-- ** Operators
newtype Unit
= Unit Text
deriving (Data, Eq, IsString, Ord, Show, Typeable)
-instance Unit.Unit Unit where
+instance H.Unit Unit where
unit_empty = Unit ""
unit_text (Unit t) = t
instance NFData Unit where
-- | 'Unit.unit_empty'.
unit_scalar :: Unit
-unit_scalar = Unit.unit_empty
+unit_scalar = H.unit_empty
-- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
unit_chf :: Unit
= Amount
{ amount_unit :: !Unit
, amount_quantity :: !Quantity
- } deriving (Data, Show, Typeable)
-instance Amount.Amount Amount where
+ } deriving (Data, Eq, Show, Typeable)
+instance H.Amount Amount where
type Amount_Quantity Amount = Quantity
type Amount_Unit Amount = Unit
amount_quantity = amount_quantity
amount_unit = amount_unit
-instance Filter.Amount Amount where
- type Amount_Quantity Amount = Quantity
- type Amount_Unit Amount = Unit
- amount_quantity = Polarize.polarize . amount_quantity
- amount_unit = amount_unit
instance NFData Amount where
rnf (Amount q u) = rnf q `seq` rnf u
-instance Quantity.Zero Amount where
- quantity_zero = Amount Unit.unit_empty Quantity.quantity_zero
- quantity_null = (==) Quantity.quantity_zero . amount_quantity
+instance H.Zero Amount where
+ quantity_zero = Amount H.unit_empty H.quantity_zero
+ quantity_null = (==) H.quantity_zero . amount_quantity
amount :: Amount
amount =
Amount
- { amount_quantity = Quantity.quantity_zero
+ { amount_quantity = H.quantity_zero
, amount_unit = ""
}
-- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
-- at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
amount_null :: Amount -> Bool
-amount_null = Quantity.quantity_null . amount_quantity
+amount_null = H.quantity_null . amount_quantity
{-
instance Eq Amount where
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hcompta.Ledger.Chart where
+
+import Control.DeepSeq (NFData(..))
+import Data.Data
+import Data.Eq (Eq)
+import Data.Foldable (Foldable)
+import Data.Function (on, (.))
+import Data.Functor (Functor)
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Data.Traversable (Traversable)
+import Data.TreeMap.Strict (TreeMap)
+import Data.Typeable ()
+import Text.Show (Show)
+
+import qualified Hcompta.Account as H
+import Hcompta.Ledger.Account
+
+-- * Type 'Chart'
+
+data Chart
+ = Chart
+ { chart_accounts :: TreeMap (H.Account_Section Account) H.Account_Tags
+ } deriving (Data, Eq, Show, Typeable)
+instance NFData Chart where
+ rnf Chart{..} =
+ rnf chart_accounts
+instance Monoid Chart where
+ mempty = Chart
+ { chart_accounts = mempty
+ }
+ mappend x y =
+ Chart
+ { chart_accounts = chart_accounts x `mappend` chart_accounts y
+ }
+
+-- * Type 'Charted'
+
+data Charted a
+ = Charted
+ { chart :: Chart
+ , charted :: a
+ } deriving (Data, Eq, Foldable, Functor, Show, Traversable, Typeable)
+
+instance Ord a => Ord (Charted a) where
+ compare = compare `on` charted
+instance H.Account (Charted Account) where
+ type Account_Section (Charted Account) = H.Account_Section Account
+ account_path = H.account_path . charted
--- /dev/null
+../HLint.hs
\ No newline at end of file
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
-module Hcompta.Format.Ledger.Journal where
+module Hcompta.Ledger.Journal where
import Control.DeepSeq (NFData(..))
import Control.Monad (Monad(..), foldM)
import Prelude (seq, min)
import System.IO (FilePath)
-import Hcompta.Date (Date)
-import qualified Hcompta.Date as Date
-import Hcompta.Format.Ledger.Amount
-import Hcompta.Format.Ledger.Chart
+import qualified Hcompta as H
+import Hcompta.Ledger.Amount
+import Hcompta.Ledger.Chart
-- * Type 'Journal'
data Journal j
- = Journal
- { journal_amount_styles :: !Amount_Styles
- , journal_chart :: Chart
- , journal_content :: !j
- , journal_files :: [FilePath]
- , journal_includes :: [Journal j]
- , journal_last_read_time :: Date
+ = Journal
+ { journal_amount_styles :: !Amount_Styles
+ , journal_chart :: Chart
+ , journal_content :: !j
+ , journal_files :: [FilePath]
+ , journal_includes :: [Journal j]
+ , journal_last_read_time :: H.Date
} deriving (Data, Eq, Show, Typeable)
instance Functor Journal where
, journal_content = mempty
, journal_files = mempty
, journal_includes = mempty
- , journal_last_read_time = Date.nil
+ , journal_last_read_time = H.date_epoch
}
instance Monoid j => Monoid (Journal j) where
--- /dev/null
+module Hcompta.Ledger.Lib.FilePath where
+
+import Control.Applicative ((<$>))
+import Control.Monad (Monad(..))
+import Control.Monad.IO.Class (liftIO)
+import Prelude (($), FilePath, IO, id)
+import System.Directory (getHomeDirectory)
+import System.FilePath ((</>))
+import qualified System.FilePath.Posix as Path
+
+-- | Return an absolute 'FilePath', given the current working directory and a path.
+--
+-- * "~" as prefix is expanded to the process's user's home directory
+-- * "-" as path is unchanged
+-- * ~USER is not supported
+path_absolute :: FilePath -> FilePath -> IO FilePath
+path_absolute _ "-" = return "-"
+path_absolute cwd path =
+ (if Path.isRelative path
+ then (cwd </>)
+ else id) <$>
+ expand path
+ where
+ expand :: FilePath -> IO FilePath
+ expand ('~':sep:p) =
+ if Path.isPathSeparator sep
+ then liftIO $ (</> p) <$> getHomeDirectory
+ else fail "~USERNAME in path is not supported"
+ expand p = return p
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Ledger.Lib.Parsec where
+
+import Control.Monad (Monad(..))
+import Data.Char (Char)
+import qualified Data.Char as Char
+import qualified Data.Foldable as Foldable
+import Data.Function (($), (.))
+import Data.String (String)
+import Prelude (Integer, Integral(..), Num(..), seq)
+import Text.Parsec (Stream, ParsecT, (<|>))
+import qualified Text.Parsec as R
+
+-- * Useful combinators
+
+-- | Like 'R.choice' but with 'R.try' on each case.
+choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
+choice_try = Foldable.foldr ((<|>) . R.try) R.parserZero
+-- choice_try = R.choice . fmap R.try
+
+-- | Like 'R.sepBy' but without parsing an ending separator.
+many_separated
+ :: Stream s m t
+ => ParsecT s u m a
+ -> ParsecT s u m b
+ -> ParsecT s u m [a]
+many_separated p sep =
+ R.option [] $ do
+ x <- R.try p
+ xs <- R.many (R.try (sep >> p))
+ return $ x:xs
+
+-- | Like 'R.sepBy1' but without parsing an ending separator.
+many1_separated
+ :: Stream s m t
+ => ParsecT s u m a
+ -> ParsecT s u m b
+ -> ParsecT s u m [a]
+many1_separated p sep = do
+ x <- p
+ xs <- R.many (R.try (sep >> p))
+ return $ x:xs
+-- (:) <$> p <*> R.many (R.try (sep >> p))
+
+-- | Make a 'R.ParsecT' also return its user state.
+and_state
+ :: Stream s m t
+ => ParsecT s u m a
+ -> ParsecT s u m (a, u)
+and_state p = do
+ a <- p
+ s <- R.getState
+ return (a, s)
+
+-- * Numbers
+
+-- | Return the 'Integer' obtained by multiplying the given digits
+-- with the power of the given base respective to their rank.
+integer_of_digits
+ :: Integer -- ^ Base.
+ -> String -- ^ Digits (MUST be recognised by 'Char.digitToInt').
+ -> Integer
+integer_of_digits base =
+ Foldable.foldl' (\x d ->
+ base*x + toInteger (Char.digitToInt d)) 0
+
+decimal :: Stream s m Char => ParsecT s u m Integer
+decimal = integer 10 R.digit
+hexadecimal :: Stream s m Char => ParsecT s u m Integer
+hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
+octal :: Stream s m Char => ParsecT s u m Integer
+octal = R.oneOf "oO" >> integer 8 R.octDigit
+
+-- | Parse an 'Integer'.
+integer :: Stream s m t
+ => Integer
+ -> ParsecT s u m Char
+ -> ParsecT s u m Integer
+integer base digit = do
+ digits <- R.many1 digit
+ let n = integer_of_digits base digits
+ seq n (return n)
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hcompta.Ledger.Posting where
+
+import Control.DeepSeq (NFData(..))
+import Data.Bool
+import Data.Data (Data(..))
+import Data.Eq (Eq(..))
+import Data.Function ((.), flip)
+import Data.Functor (Functor(..), (<$>))
+import qualified Data.List as List
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Text (Text)
+import Data.Tuple (uncurry)
+import Data.Typeable (Typeable)
+import Prelude (seq)
+import Text.Parsec.Pos (SourcePos, initialPos)
+import Text.Show (Show)
+
+import qualified Hcompta as H
+import Hcompta.Ledger.Account
+import Hcompta.Ledger.Amount
+import Hcompta.Ledger.Chart
+
+-- * Type 'Posting'
+
+data Posting
+ = Posting
+ { posting_account :: Account
+ , posting_amounts :: Map Unit Quantity
+ , posting_comments :: [Comment]
+ , posting_dates :: [H.Date]
+ , posting_sourcepos :: SourcePos
+ , posting_status :: Bool
+ , posting_tags :: H.Posting_Tags
+ } deriving (Data, Eq, Show, Typeable)
+instance NFData Posting where
+ rnf Posting{..} =
+ rnf posting_account `seq`
+ rnf posting_amounts `seq`
+ rnf posting_comments `seq`
+ rnf posting_dates `seq`
+ -- rnf posting_sourcepos `seq`
+ rnf posting_status `seq`
+ rnf posting_tags
+
+posting :: Account -> Posting
+posting acct =
+ Posting
+ { posting_account = acct
+ , posting_amounts = mempty
+ , posting_comments = mempty
+ , posting_dates = mempty
+ , posting_status = False
+ , posting_sourcepos = initialPos ""
+ , posting_tags = mempty
+ }
+
+postings_by_account :: [Posting] -> Map Account [Posting]
+postings_by_account =
+ Map.fromListWith (flip mappend) .
+ List.map (\p -> (posting_account p, [p]))
+
+-- Posting
+instance H.Posting Posting where
+ type Posting_Account Posting = Account
+ type Posting_Amount Posting = Amount
+ type Posting_Amounts Posting = [Amount]
+ posting_account = posting_account
+ posting_amounts = List.map (uncurry Amount) . Map.toList . posting_amounts
+instance H.Posting (Charted Posting) where
+ type Posting_Account (Charted Posting) = Charted Account
+ type Posting_Amount (Charted Posting) = H.Posting_Amount Posting
+ type Posting_Amounts (Charted Posting) = H.Posting_Amounts Posting
+ posting_account = (H.posting_account <$>)
+ posting_amounts = H.posting_amounts . charted
+
+-- Balance
+instance H.Balance_Posting Posting where
+ type Balance_Posting_Quantity Posting = H.Polarized Quantity
+ balance_posting_amounts = (H.polarize <$>) . posting_amounts
+ balance_posting_amounts_set amounts p =
+ p { posting_amounts = H.depolarize <$> amounts }
+instance H.Balance_Posting (Charted Posting) where
+ type Balance_Posting_Quantity (Charted Posting) = H.Balance_Posting_Quantity Posting
+ balance_posting_amounts = H.balance_posting_amounts . charted
+ balance_posting_amounts_set amounts (Charted c p) =
+ Charted c p{ posting_amounts = H.depolarize <$> amounts }
+
+-- GL
+instance H.GL_Posting Posting where
+ type GL_Posting_Quantity Posting = Map Unit (H.Polarized Quantity)
+ gl_posting_quantity = (H.polarize <$>) . posting_amounts
+instance H.GL_Posting (Charted Posting) where
+ type GL_Posting_Quantity (Charted Posting) = H.GL_Posting_Quantity Posting
+ gl_posting_quantity = H.gl_posting_quantity . charted
+
+-- ** Type 'Comment'
+
+type Comment = Text
+
+-- ** Type 'Posting_Type'
+
+data Posting_Type
+ = Posting_Type_Regular
+ | Posting_Type_Virtual
+ | Posting_Type_Virtual_Balanced
+ deriving (Data, Eq, Show, Typeable)
+
+data Posting_Typed posting
+ = Posting_Typed Posting_Type posting
+ deriving (Data, Eq, Functor, Show, Typeable)
+
+posting_type :: Posting -> Posting_Type
+posting_type Posting{posting_tags=H.Posting_Tags (H.Tags attrs)} =
+ case Map.lookup ("Virtual":|[]) attrs of
+ Nothing -> Posting_Type_Regular
+ Just l | "Balanced" `List.elem` l -> Posting_Type_Virtual_Balanced
+ Just _ -> Posting_Type_Virtual
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Format.Ledger.Quantity where
+module Hcompta.Ledger.Quantity where
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-module Hcompta.Format.Ledger.Read where
+module Hcompta.Ledger.Read where
-import Control.Applicative ((<$>), (<*>), (<*))
+import Prelude (Int, Integer, Num(..), fromIntegral)
+import Control.Applicative (Applicative(..))
import Control.Arrow ((***), first)
-import qualified Control.Exception as Exception
-import Control.Monad (Monad(..), guard, liftM, join, forM, void)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT(..), throwE)
-import Data.Time.LocalTime (TimeZone(..))
import Data.Bool
-import Data.Decimal
import Data.Char (Char)
import qualified Data.Char as Char
+import Data.Decimal
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
-import Data.Ord (Ord(..))
+import qualified Control.Exception.Safe as Exn
+import qualified System.FilePath.Posix as FilePath
import Data.Function (($), (.), id, const, flip)
-import Data.Functor (Functor(..))
+import Data.Functor ((<$>))
+import System.IO (IO, FilePath)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Control.Monad (Monad(..), forM, guard, join, void)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT(..), throwE)
import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import Data.String (String, fromString)
-import qualified Data.Text as Text
import Data.Text (Text)
+import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO (readFile)
import qualified Data.Time.Calendar as Time
import qualified Data.Time.Clock as Time
+import Data.Time.LocalTime (TimeZone(..))
import qualified Data.Time.LocalTime as Time
import Data.Typeable ()
-import Prelude (Int, Integer, Num(..), fromIntegral)
-import qualified System.FilePath.Posix as Path
-import System.IO (IO, FilePath)
import qualified Text.Parsec as R hiding
( char
, anyChar
, string
, tab
)
-import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
+import qualified Text.Parsec.Error.Custom as R
import qualified Text.Parsec.Pos as R
+import Text.Regex.TDFA (Regex)
+import qualified Text.Regex.TDFA.Replace.Text as Regex
import Text.Show (Show)
-import qualified Hcompta.Account as Account
-import Hcompta.Account (Account_Tags(..))
-import qualified Hcompta.Amount as Amount
-import qualified Hcompta.Balance as Balance
-import qualified Hcompta.Chart as Chart
-import Hcompta.Date (Date)
-import qualified Hcompta.Date as Date
+import qualified Hcompta as H
import Hcompta.Lib.Consable (Consable(..))
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Lib.Path as Path
-import Hcompta.Lib.Regex (Regex)
-import qualified Hcompta.Lib.Regex as Regex
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import qualified Hcompta.Polarize as Polarize
-import Hcompta.Posting (Posting_Tags(..))
-import qualified Hcompta.Quantity as Quantity
-import Hcompta.Tag (Tag, Tags(..))
-import qualified Hcompta.Tag as Tag
-import Hcompta.Transaction (Transaction_Tags(..))
-import qualified Hcompta.Unit as Unit
-import qualified Hcompta.Filter.Date.Read as Filter.Date.Read
-import Hcompta.Filter.Date.Read (Error(..))
-
-import Hcompta.Format.Ledger
-
--- * Type 'Read_Context'
-
-data Read_Context c j
- = Read_Context
- { read_context_account_prefix :: !(Maybe Account)
- , read_context_aliases_exact :: !(Map Account Account)
- , read_context_aliases_joker :: ![(Account_Joker, Account)]
- , read_context_aliases_regex :: ![(Regex, Account)]
- , read_context_cons :: Charted Transaction -> c
- , read_context_date :: !Date
- , read_context_journal :: !(Journal j)
- , read_context_unit :: !(Maybe Unit)
- , read_context_year :: !Date.Year
+import qualified Data.TreeMap.Strict as TreeMap
+
+import Hcompta.Ledger.Account
+import Hcompta.Ledger.Amount
+import Hcompta.Ledger.Chart
+import Hcompta.Ledger.Posting
+import Hcompta.Ledger.Transaction
+import Hcompta.Ledger.Journal
+import qualified Hcompta.Ledger.Lib.Parsec as R
+import qualified Hcompta.Ledger.Lib.FilePath as FilePath
+
+-- * Type 'Context_Read'
+
+data Context_Read c j
+ = Context_Read
+ { context_read_account_prefix :: !(Maybe Account)
+ , context_read_aliases_exact :: !(Map Account Account)
+ , context_read_aliases_joker :: ![(Account_Joker, Account)]
+ , context_read_aliases_regex :: ![(Regex, Account)]
+ , context_read_cons :: Charted Transaction -> c
+ , context_read_date :: !H.Date
+ , context_read_journal :: !(Journal j)
+ , context_read_unit :: !(Maybe Unit)
+ , context_read_year :: !H.Year
}
-read_context
+context_read
:: Consable c j
=> (Charted Transaction -> c)
-> Journal j
- -> Read_Context c j
-read_context read_context_cons read_context_journal =
- Read_Context
- { read_context_account_prefix = Nothing
- , read_context_aliases_exact = mempty
- , read_context_aliases_joker = []
- , read_context_aliases_regex = []
- , read_context_cons
- , read_context_date = Date.nil
- , read_context_journal
- , read_context_unit = Nothing
- , read_context_year = Date.year Date.nil
+ -> Context_Read c j
+context_read context_read_cons context_read_journal =
+ Context_Read
+ { context_read_account_prefix = Nothing
+ , context_read_aliases_exact = mempty
+ , context_read_aliases_joker = []
+ , context_read_aliases_regex = []
+ , context_read_cons
+ , context_read_date = H.date_epoch
+ , context_read_journal
+ , context_read_unit = Nothing
+ , context_read_year = H.date_year H.date_epoch
}
--- * Type 'Read_Error'
+-- * Type 'Error_Read'
-data Read_Error
- = Read_Error_date Date_Error
- | Read_Error_transaction_not_equilibrated
+data Error_Read
+ = Error_Read_date Error_Read_Date
+ | Error_Read_transaction_not_equilibrated
Amount_Styles
Transaction
[( Unit
- , Balance.Unit_Sum Account
- (Polarize.Polarized Quantity)
+ , H.Balance_by_Unit_Sum Account_Section
+ (H.Polarized Quantity)
)]
- | Read_Error_virtual_transaction_not_equilibrated
+ | Error_Read_virtual_transaction_not_equilibrated
Amount_Styles
Transaction
[( Unit
- , Balance.Unit_Sum Account
- (Polarize.Polarized Quantity)
+ , H.Balance_by_Unit_Sum Account_Section
+ (H.Polarized Quantity)
)]
- | Read_Error_reading_file FilePath Exception.IOException
- | Read_Error_including_file FilePath [R.Error Read_Error]
- deriving (Show)
+ | Error_Read_reading_file FilePath Exn.IOException
+ | Error_Read_including_file FilePath [R.Error Error_Read]
+ deriving (Eq, Show)
-- * Read common patterns
read_hspaces :: Stream s m Char => ParsecT s u m ()
-read_hspaces = R.skipMany R.space_horizontal
+read_hspaces = R.skipMany R.spaceHorizontal
-- * Read 'Account'
read_account :: Stream s m Char => ParsecT s u m Account
read_account = do
- R.notFollowedBy $ R.space_horizontal
- Account.from_List <$> do
- R.many1_separated read_account_section $ R.char read_account_section_sep
+ R.notFollowedBy $ R.spaceHorizontal
+ (H.account_from_List <$>) $
+ R.many1_separated read_account_section $
+ R.char read_account_section_sep
read_account_section :: Stream s m Char => ParsecT s u m Text
-read_account_section = do
- fromString <$> (R.many1 $ R.try account_name_char)
+read_account_section =
+ fromString <$>
+ R.many1 (R.try account_name_char)
where
account_name_char :: Stream s m Char => ParsecT s u m Char
account_name_char = do
case c of
_ | c == read_comment_prefix -> R.parserZero
_ | c == read_account_section_sep -> R.parserZero
- _ | c /= '\t' && R.is_space_horizontal c -> do
- _ <- R.notFollowedBy $ R.space_horizontal
- return c <* (R.lookAhead $ R.try $
- ( R.try (R.char read_account_section_sep)
- <|> account_name_char
- ))
+ _ | c /= '\t' && R.isSpaceHorizontal c -> do
+ _ <- R.notFollowedBy $ R.spaceHorizontal
+ return c <* R.lookAhead (R.try $
+ R.try (R.char read_account_section_sep) <|>
+ account_name_char
+ )
_ | not (Char.isSpace c) -> return c
_ -> R.parserZero
read_comment_prefix :: Char
read_comment_prefix = ';'
-read_account_section_joker :: Stream s m Char => ParsecT s u m Account_Joker_Section
+read_account_section_joker
+ :: Stream s m Char
+ => ParsecT s u m Account_Joker_Section
read_account_section_joker = do
n <- R.option Nothing $ (Just <$> read_account_section)
case n of
Nothing -> R.char read_account_section_sep >> return Account_Joker_Any
Just n' -> return $ Account_Joker_Section n'
-read_account_joker :: Stream s m Char => ParsecT s u m Account_Joker
+read_account_joker
+ :: Stream s m Char
+ => ParsecT s u m Account_Joker
read_account_joker = do
- R.notFollowedBy $ R.space_horizontal
+ R.notFollowedBy $ R.spaceHorizontal
R.many1_separated read_account_section_joker $ R.char read_account_section_sep
-read_account_regex :: Stream s m Char => ParsecT s u m Regex
+read_account_regex
+ :: Stream s m Char
+ => ParsecT s u m Regex
read_account_regex = do
- re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
+ re <- R.many1 $ R.satisfy (not . R.isSpaceHorizontal)
Regex.of_StringM re
-read_account_pattern :: Stream s m Char => ParsecT s u m Account_Pattern
-read_account_pattern = do
+read_account_pattern
+ :: Stream s m Char
+ => ParsecT s u m Account_Pattern
+read_account_pattern =
R.choice_try
[ Account_Pattern_Exact <$> (R.char '=' >> read_account)
, Account_Pattern_Joker <$> (R.char '*' >> read_account_joker)
let digits = h:t
return (digits, Just fractioning
, grouping_of_digits frac_group_sep $ List.reverse digits)
- return $
+ return
( integral
, fractional
, fractioning
-- * Read 'Unit'
read_unit :: Stream s m Char => ParsecT s u m Unit
-read_unit =
- (quoted <|> unquoted) <?> "unit"
+read_unit = (<?> "unit") $
+ quoted <|> unquoted
where
unquoted :: Stream s m Char => ParsecT s u m Unit
unquoted =
- fromString <$> do
+ (fromString <$>) $
R.many1 $
R.satisfy $ \c ->
case Char.generalCategory c of
_ -> False
quoted :: Stream s m Char => ParsecT s u m Unit
quoted =
- fromString <$> do
+ (fromString <$>) $
R.between (R.char '"') (R.char '"') $
R.many1 $
R.noneOf ";\n\""
left_unit <-
R.option Nothing $ do
u <- read_unit
- s <- R.many $ R.space_horizontal
+ s <- R.many $ R.spaceHorizontal
return $ Just $ (u, not $ List.null s)
(qty, style) <- do
signing <- read_sign
, amount_style_fractioning
, amount_style_grouping_integral
, amount_style_grouping_fractional
- ) <-
+ ) <- (<?> "quantity") $
R.choice_try
- [ read_quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , read_quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , read_quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , read_quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- ] <?> "quantity"
+ [ read_quantity '_' ',' '_' <* R.notFollowedBy (R.oneOf ",._")
+ , read_quantity '_' '.' '_' <* R.notFollowedBy (R.oneOf ",._")
+ , read_quantity ',' '.' '_' <* R.notFollowedBy (R.oneOf ",._")
+ , read_quantity '.' ',' '_' <* R.notFollowedBy (R.oneOf ",._")
+ ]
let int = List.concat amount_style_integral
let frac = List.concat amount_style_fractional
let precision = List.length frac
guard (precision <= 255)
let mantissa = R.integer_of_digits 10 $ int `mappend` frac
return $
- ( Data.Decimal.Decimal
+ ( Decimal
(fromIntegral precision)
(signing mantissa)
, mempty
Just (u, s) ->
return (u, Just Amount_Style_Side_Left, Just s)
Nothing ->
- R.option (Unit.unit_empty, Nothing, Nothing) $ R.try $ do
- s <- R.many R.space_horizontal
+ R.option (H.unit_empty, Nothing, Nothing) $ R.try $ do
+ s <- R.many R.spaceHorizontal
u <- read_unit
return $
( u
-- * Read 'Date'
-type Date_Error = Filter.Date.Read.Error
+data Error_Read_Date
+ = Error_Read_Date_year_or_day_is_missing
+ | Error_Read_Date_invalid_date (Integer, Int, Int)
+ | Error_Read_Date_invalid_time_of_day (Int, Int, Integer)
+ deriving (Eq, Show)
-- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
read_date
- :: (Stream s (R.Error_State e m) Char, Monad m)
- => (Date_Error -> e) -> Maybe Integer
- -> ParsecT s u (R.Error_State e m) Date
-read_date err def_year = (do
+ :: (Stream s (R.State_Error e m) Char, Monad m)
+ => (Error_Read_Date -> e) -> Maybe Integer
+ -> ParsecT s u (R.State_Error e m) H.Date
+read_date err def_year = (<?> "date") $ do
let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
n0 <- R.many1 R.digit
day_sep <- R.char read_date_ymd_sep
Just <$> read_2_or_1_digits
(year, m, d) <-
case (n2, def_year) of
- (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing)
+ (Nothing, Nothing) -> R.parserFailWith "date" $
+ err Error_Read_Date_year_or_day_is_missing
(Nothing, Just year) -> return (year, n0, n1)
(Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
let month = fromInteger $ R.integer_of_digits 10 m
let dom = fromInteger $ R.integer_of_digits 10 d
day <- case Time.fromGregorianValid year month dom of
- Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
+ Nothing -> R.parserFailWith "date" $
+ err $ Error_Read_Date_invalid_date (year, month, dom)
Just day -> return day
(hour, minu, sec, tz) <-
R.option (0, 0, 0, Time.utc) $ R.try $ do
, maybe 0 (R.integer_of_digits 10) sec
, tz )
tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
- Nothing -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
+ Nothing -> R.parserFailWith "date" $
+ err $ Error_Read_Date_invalid_time_of_day (hour, minu, sec)
Just tod -> return tod
return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
- ) <?> "date"
-- | Separator for year, month and day: "-".
read_date_ymd_sep :: Char
read_hour_separator = ':'
read_time_zone :: Stream s m Char => ParsecT s u m TimeZone
-read_time_zone = Filter.Date.Read.time_zone
+read_time_zone =
+ -- DOC: http://www.timeanddate.com/time/zones/
+ -- TODO: only a few time zones are suported below.
+ -- TODO: check the timeZoneSummerOnly values
+ R.choice
+ [ R.char '_' >>
+ R.choice
+ [ R.char 'A' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
+ , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
+ , return (TimeZone ((-1) * 60) False "A")
+ ]
+ , R.char 'B' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
+ , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
+ ]
+ , R.char 'C' >> R.choice
+ [ R.char 'E' >> R.choice
+ [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
+ , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
+ ]
+ , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
+ , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
+ ]
+ , R.char 'E' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
+ , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
+ ]
+ , R.string "GMT" >> return (TimeZone 0 False "GMT")
+ , R.char 'H' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
+ , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
+ ]
+ , R.char 'M' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
+ , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
+ , return (TimeZone ((-12) * 60) False "M")
+ ]
+ , R.char 'N' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
+ , return (TimeZone (1 * 60) False "N")
+ ]
+ , R.char 'P' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
+ , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
+ ]
+ , R.char 'Y' >> R.choice
+ [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
+ , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
+ , return (TimeZone (12 * 60) False "Y")
+ ]
+ , R.char 'Z' >> return (TimeZone 0 False "Z")
+ ]
+ , read_time_zone_digits
+ ]
read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
-read_time_zone_digits = Filter.Date.Read.time_zone_digits
+read_time_zone_digits = do
+ sign_ <- read_sign
+ hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
+ minute <-
+ R.option 0 $ do
+ void $ R.char ':'
+ R.integer_of_digits 10 <$> R.count 2 R.digit
+ let tz = TimeZone
+ { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
+ , timeZoneSummerOnly = False
+ , timeZoneName = Time.timeZoneOffsetString tz
+ }
+ return tz
-- * Read 'Comment'
read_comment
:: Stream s m Char
=> ParsecT s u m Comment
-read_comment = (do
+read_comment = (<?> "comment") $ do
_ <- R.char read_comment_prefix
- fromString <$> do
- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
- ) <?> "comment"
+ (fromString <$>) $
+ R.manyTill R.anyChar (R.lookAhead (R.try R.newline <|> R.eof))
-- ** Read 'Comment's
read_comments
:: Stream s m Char
=> ParsecT s u m [Comment]
-read_comments = (do
- R.try $ do
+read_comments = (<?> "comments") $
+ R.try (do
_ <- R.spaces
R.many1_separated read_comment
- (R.new_line >> read_hspaces)
+ (R.newline >> read_hspaces))
<|> return []
- ) <?> "comments"
-- * Read 'Tag'
:: Stream s m Char
=> ParsecT s u m Char
read_tag_path_section_char =
- R.satisfy (\c -> c /= read_tag_value_sep
- && c /= read_tag_sep
- && not (Char.isSpace c))
-
-read_tag :: Stream s m Char => ParsecT s u m Tag
-read_tag = ((,) <$> read_tag_path <*> read_tag_value) <?> "tag"
-
-read_tag_path :: Stream s m Char => ParsecT s u m Tag.Path
-read_tag_path = do
- NonEmpty.fromList <$> do
+ R.satisfy $ \c ->
+ c /= read_tag_value_sep &&
+ c /= read_tag_sep &&
+ not (Char.isSpace c)
+
+read_tag :: Stream s m Char => ParsecT s u m H.Tag
+read_tag = (<?> "tag") $
+ (,)
+ <$> read_tag_path
+ <*> read_tag_value
+
+read_tag_path :: Stream s m Char => ParsecT s u m H.Tag_Path
+read_tag_path =
+ (NonEmpty.fromList <$>) $
R.many1 $ R.try read_tag_path_section
-read_tag_path_section :: Stream s m Char => ParsecT s u m Tag.Section
-read_tag_path_section = do
- fromString <$> do
- ((R.many1 $ read_tag_path_section_char) <* R.char read_tag_value_sep)
+read_tag_path_section :: Stream s m Char => ParsecT s u m H.Tag_Section
+read_tag_path_section =
+ (fromString <$>) $
+ (R.many1 read_tag_path_section_char <* R.char read_tag_value_sep)
-read_tag_value :: Stream s m Char => ParsecT s u m Tag.Value
-read_tag_value = do
- fromString <$> do
- R.manyTill R.anyChar $ do
- R.lookAhead $ do
+read_tag_value :: Stream s m Char => ParsecT s u m H.Tag_Value
+read_tag_value =
+ (fromString <$>) $
+ R.manyTill R.anyChar $
+ R.lookAhead $
R.try (R.char read_tag_sep
- >> R.many R.space_horizontal
+ >> R.many R.spaceHorizontal
>> void read_tag_path_section)
- <|> R.try (void (R.try R.new_line))
+ <|> R.try (void (R.try R.newline))
<|> R.eof
-- ** Read 'Tag's
read_tags
:: Stream s m Char
- => ParsecT s u m (Map Tag.Path [Tag.Value])
-read_tags = do
- Map.fromListWith (flip mappend)
- . List.map (\(p, v) -> (p, [v])) <$> do
+ => ParsecT s u m (Map H.Tag_Path [H.Tag_Value])
+read_tags =
+ (Map.fromListWith (flip mappend) .
+ List.map (\(p, v) -> (p, [v])) <$>) $
R.many_separated read_tag $ do
_ <- R.char read_tag_sep
read_hspaces
read_not_tag :: Stream s m Char => ParsecT s u m [Char]
-read_not_tag = do
+read_not_tag =
R.many $ R.try $ do
R.skipMany $
R.satisfy (\c -> c /= read_tag_value_sep && not (Char.isSpace c))
- R.space_horizontal
+ R.spaceHorizontal
-- * Read 'Posting'
read_posting ::
( Consable c j
, Monad m
- , Stream s (R.Error_State Read_Error m) Char
- ) => ParsecT s (Read_Context c j)
- (R.Error_State Read_Error m)
+ , Stream s (R.State_Error Error_Read m) Char
+ ) => ParsecT s (Context_Read c j)
+ (R.State_Error Error_Read m)
(Posting_Typed Posting)
-read_posting = (do
+read_posting = (<?> "posting") $ do
posting_sourcepos <- R.getPosition
- R.skipMany1 $ R.space_horizontal
+ R.skipMany1 $ R.spaceHorizontal
posting_status <- read_status
read_hspaces
acct <- read_account
let Posting_Typed type_ posting_account = read_posting_type acct
- posting_amounts <-
+ posting_amounts <- (<?> "amounts") $
R.choice_try
[ do
- (void R.tab <|> void (R.count 2 R.space_horizontal))
+ (void R.tab <|> void (R.count 2 R.spaceHorizontal))
read_hspaces
amts <-
R.many_separated read_amount $ do
read_hspaces
_ <- R.char read_amount_sep
read_hspaces
- ctx <- flip liftM R.getState $ \ctx ->
+ ctx <- (<$> R.getState) $ \ctx ->
ctx
- { read_context_journal=
- let jnl = read_context_journal ctx in
+ { context_read_journal=
+ let jnl = context_read_journal ctx in
jnl
{ journal_amount_styles =
List.foldl'
(\(Amount_Styles styles) (style, amt) ->
Amount_Styles $
Map.insertWith (flip mappend) -- NOTE: prefer first style
- (Amount.amount_unit amt)
+ (H.amount_unit amt)
style styles)
(journal_amount_styles jnl)
amts
}
R.setState ctx
return $
- Map.fromListWith Quantity.quantity_add $
+ Map.fromListWith H.quantity_add $
List.map
(\(_sty, amt) ->
- let unit = Amount.amount_unit amt in
- ( if unit == Unit.unit_empty
- then maybe unit id (read_context_unit ctx)
+ let unit = H.amount_unit amt in
+ ( if unit == H.unit_empty
+ then fromMaybe unit $ context_read_unit ctx
else unit
- , Amount.amount_quantity amt
+ , H.amount_quantity amt
)
)
amts
, return mempty
- ] <?> "amounts"
+ ]
read_hspaces
-- TODO: balance assertion
-- TODO: conversion
posting_comments <- read_comments
- let posting_tags@(Tags tags_) =
+ let posting_tags@(H.Tags tags_) =
tags_of_comments posting_comments
posting_dates <- do
ctx <- R.getState
Nothing -> return []
Just dates -> do
let date2s = Map.lookup ("date2":|[]) tags_ -- NOTE: support hledger's date2
- do
- forM (dates `mappend` fromMaybe [] date2s) $ \s ->
- R.runParserT_with_Error_fail "tag date" id
- (read_date Read_Error_date (Just $ read_context_year ctx) <* R.eof) ()
+ dates_ <- forM (dates `mappend` fromMaybe [] date2s) $ \s ->
+ R.runParserTWithErrorPropagation "tag date" id
+ (read_date Error_Read_date (Just $ context_read_year ctx) <* R.eof) ()
(Text.unpack s) s
- >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
+ case (dates, date2s) of
+ -- NOTE: put hledger's date2 at least in second position
([], Just (_:_)) ->
- return $ read_context_date ctx:dates_
+ return $ context_read_date ctx:dates_
_ -> return $ dates_
return $ Posting_Typed type_ Posting
{ posting_account
, posting_dates
, posting_sourcepos
, posting_status
- , posting_tags = Posting_Tags posting_tags
+ , posting_tags = H.Posting_Tags posting_tags
}
- ) <?> "posting"
read_amount_sep :: Char
read_amount_sep = '+'
-tags_of_comments :: [Comment] -> Tags
+tags_of_comments :: [Comment] -> H.Tags
tags_of_comments =
- Tags .
+ H.Tags .
Map.unionsWith mappend
. List.map
( Data.Either.either (const Map.empty) id
)
read_status :: Stream s m Char => ParsecT s u m Status
-read_status = (do
- ( R.try $ do
+read_status = (<?> "status") $
+ R.try $ do
read_hspaces
_ <- (R.char '*' <|> R.char '!')
- return True )
+ return True
<|> return False
- ) <?> "status"
-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
read_posting_type :: Account -> (Posting_Typed Account)
read_posting_type acct =
- fromMaybe (Posting_Typed Posting_Type_Regular acct) $ do
+ fromMaybe (Posting_Typed Posting_Type_Regular acct) $
case acct of
name:|[] ->
case Text.stripPrefix virtual_begin name of
Just name' -> do
- name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
+ name'' <- Text.strip <$> Text.stripSuffix virtual_end name'
guard $ not $ Text.null name''
Just $ Posting_Typed Posting_Type_Virtual $ name'':|[]
Nothing -> do
- name' <- liftM Text.strip $
+ name' <- Text.strip <$>
Text.stripPrefix virtual_balanced_begin name
>>= Text.stripSuffix virtual_balanced_end
guard $ not $ Text.null name'
first_name:|acct' -> do
let rev_acct' = List.reverse acct'
let last_name = List.head rev_acct'
- case liftM Text.stripStart $
+ case Text.stripStart <$>
Text.stripPrefix virtual_begin first_name of
Just first_name' -> do
- last_name' <- liftM Text.stripEnd $
+ last_name' <- Text.stripEnd <$>
Text.stripSuffix virtual_end last_name
guard $ not $ Text.null first_name'
guard $ not $ Text.null last_name'
Posting_Type_Virtual $
first_name':| List.reverse (last_name':List.tail rev_acct')
Nothing -> do
- first_name' <- liftM Text.stripStart $
+ first_name' <- Text.stripStart <$>
Text.stripPrefix virtual_balanced_begin first_name
- last_name' <- liftM Text.stripEnd $
+ last_name' <- Text.stripEnd <$>
Text.stripSuffix virtual_balanced_end last_name
guard $ not $ Text.null first_name'
guard $ not $ Text.null last_name'
read_transaction ::
( Consable c j
, Monad m
- , Stream s (R.Error_State Read_Error m) Char
- ) => ParsecT s (Read_Context c j)
- (R.Error_State Read_Error m)
+ , Stream s (R.State_Error Error_Read m) Char
+ ) => ParsecT s (Context_Read c j)
+ (R.State_Error Error_Read m)
Transaction
-read_transaction = (do
+read_transaction = (<?> "transaction") $ do
ctx <- R.getState
transaction_sourcepos <- R.getPosition
- transaction_comments_before <-
- read_comments
- >>= \x -> case x of
+ transaction_comments_before <- do
+ cmts <- read_comments
+ case cmts of
[] -> return []
- _ -> return x <* R.new_line
- date_ <- read_date Read_Error_date (Just $ read_context_year ctx)
+ _ -> return cmts <* R.newline
+ date_ <- read_date Error_Read_date (Just $ context_read_year ctx)
dates_ <-
R.option [] $ R.try $ do
read_hspaces
_ <- R.char read_transaction_date_sep
read_hspaces
R.many_separated
- (read_date Read_Error_date (Just $ read_context_year ctx)) $
+ (read_date Error_Read_date (Just $ context_read_year ctx)) $
R.try $ do
- R.many $ R.space_horizontal
- >> R.char read_transaction_date_sep
- >> (R.many $ R.space_horizontal)
+ void $ R.many $ R.spaceHorizontal
+ void $ R.char read_transaction_date_sep
+ R.many $ R.spaceHorizontal
let transaction_dates = (date_, dates_)
read_hspaces
transaction_status <- read_status
read_hspaces
transaction_comments_after <- read_comments
let transaction_tags =
- Transaction_Tags $
+ H.Transaction_Tags $
mappend
(tags_of_comments transaction_comments_before)
(tags_of_comments transaction_comments_after)
- R.new_line
+ R.newline
(postings_unchecked, postings_not_regular) <-
first (postings_by_account . List.map
(\(Posting_Typed _ p) -> p)) .
List.partition (\(Posting_Typed pt _) ->
Posting_Type_Regular == pt) <$>
- R.many1_separated read_posting R.new_line
+ R.many1_separated read_posting R.newline
let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
join (***) (postings_by_account . List.map
(\(Posting_Typed _ p) -> p)) $
, transaction_status
, transaction_tags
}
- let styles = journal_amount_styles $ read_context_journal ctx
+ let styles = journal_amount_styles $ context_read_journal ctx
transaction_postings <-
- case Balance.infer_equilibrium postings_unchecked of
- (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
- Read_Error_transaction_not_equilibrated styles tr_unchecked ko
+ case H.balance_infer_equilibrium postings_unchecked of
+ (_, Left ko) -> R.parserFailWith "transaction: balance_infer_equilibrium" $
+ Error_Read_transaction_not_equilibrated styles tr_unchecked ko
(_bal, Right ok) -> return ok
transaction_balanced_virtual_postings <-
- case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
- (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
- Read_Error_virtual_transaction_not_equilibrated styles tr_unchecked ko
+ case H.balance_infer_equilibrium balanced_virtual_postings_unchecked of
+ (_, Left ko) -> R.parserFailWith "transaction: balance_infer_equilibrium" $
+ Error_Read_virtual_transaction_not_equilibrated styles tr_unchecked ko
(_bal, Right ok) -> return ok
return $
tr_unchecked
{ transaction_postings =
Map.unionsWith mappend
[ transaction_postings
- , fmap (fmap set_virtual_tag) transaction_virtual_postings
- , fmap (fmap set_virtual_tag) transaction_balanced_virtual_postings
+ , (set_virtual_tag <$>) <$> transaction_virtual_postings
+ , (set_virtual_tag <$>) <$> transaction_balanced_virtual_postings
]
}
- ) <?> "transaction"
where
set_virtual_tag :: Posting -> Posting
set_virtual_tag
- p@Posting{posting_tags=Posting_Tags (Tags attrs)} =
- p{posting_tags = Posting_Tags $ Tags $ Map.insert ("Virtual":|[]) [] attrs}
+ p@Posting{posting_tags=H.Posting_Tags (H.Tags attrs)} =
+ p{posting_tags = H.Posting_Tags $ H.Tags $ Map.insert ("Virtual":|[]) [] attrs}
read_transaction_date_sep :: Char
read_transaction_date_sep = '='
read_code
:: ( Consable c j
, Stream s m Char )
- => ParsecT s (Read_Context c j) m Code
-read_code = (do
- fromString <$> do
- read_hspaces
- R.between (R.char '(') (R.char ')') $
- R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
- ) <?> "code"
+ => ParsecT s (Context_Read c j) m Code
+read_code = (<?> "code") $
+ (fromString <$>) $ do
+ read_hspaces
+ R.between (R.char '(') (R.char ')') $
+ R.many $ R.satisfy (\c -> c /= ')' && not (R.isSpaceHorizontal c))
read_wording
:: Stream s m Char
=> ParsecT s u m Wording
-read_wording = (do
- fromString <$> do
- R.many $ R.try read_wording_char
- ) <?> "wording"
+read_wording = (<?> "wording") $
+ (fromString <$>) $
+ R.many $ R.try read_wording_char
where
read_wording_char :: Stream s m Char => ParsecT s u m Char
read_wording_char = do
c <- R.anyChar
case c of
_ | c == read_comment_prefix -> R.parserZero
- _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ read_wording_char)
+ _ | R.isSpaceHorizontal c -> return c <* R.lookAhead (R.try $ read_wording_char)
_ | not (Char.isSpace c) -> return c
_ -> R.parserZero
read_directive_alias
:: (Consable c j, Stream s m Char)
- => ParsecT s (Read_Context c j) m ()
+ => ParsecT s (Context_Read c j) m ()
read_directive_alias = do
_ <- R.string "alias"
- R.skipMany1 $ R.space_horizontal
- pattern <- read_account_pattern
+ R.skipMany1 $ R.spaceHorizontal
+ pat <- read_account_pattern
read_hspaces
_ <- R.char '='
read_hspaces
repl <- read_account
read_hspaces
- case pattern of
+ case pat of
Account_Pattern_Exact acct ->
- R.modifyState $ \ctx -> ctx{read_context_aliases_exact=
- Map.insert acct repl $ read_context_aliases_exact ctx}
+ R.modifyState $ \ctx -> ctx{context_read_aliases_exact=
+ Map.insert acct repl $ context_read_aliases_exact ctx}
Account_Pattern_Joker jokr ->
- R.modifyState $ \ctx -> ctx{read_context_aliases_joker=
- (jokr, repl):read_context_aliases_joker ctx}
+ R.modifyState $ \ctx -> ctx{context_read_aliases_joker=
+ (jokr, repl):context_read_aliases_joker ctx}
Account_Pattern_Regex regx ->
- R.modifyState $ \ctx -> ctx{read_context_aliases_regex=
- (regx, repl):read_context_aliases_regex ctx}
+ R.modifyState $ \ctx -> ctx{context_read_aliases_regex=
+ (regx, repl):context_read_aliases_regex ctx}
return ()
read_default_year
:: (Consable c j, Stream s m Char)
- => ParsecT s (Read_Context c j) m ()
-read_default_year = (do
+ => ParsecT s (Context_Read c j) m ()
+read_default_year = (<?> "default_year") $ do
year <- R.integer_of_digits 10 <$> R.many1 R.digit
read_hspaces
- read_context_ <- R.getState
- R.setState read_context_{read_context_year=year}
- ) <?> "default year"
+ context_read_ <- R.getState
+ R.setState context_read_{context_read_year=year}
read_default_unit_and_style
:: ( Consable c j
, Stream s m Char )
- => ParsecT s (Read_Context c j) m ()
-read_default_unit_and_style = (do
+ => ParsecT s (Context_Read c j) m ()
+read_default_unit_and_style = (<?> "default_unit_and_style") $ do
(sty, amt) <- read_amount
read_hspaces
ctx <- R.getState
- let unit = Amount.amount_unit amt
+ let unit = H.amount_unit amt
R.setState ctx
- { read_context_journal =
- let jnl = read_context_journal ctx in
+ { context_read_journal =
+ let jnl = context_read_journal ctx in
jnl
{ journal_amount_styles =
let Amount_Styles styles =
Amount_Styles $
Map.insertWith const unit sty styles
}
- , read_context_unit = Just unit
+ , context_read_unit = Just unit
}
- ) <?> "default unit and style"
read_include ::
( Consable c j
, Monoid j
- , Stream s (R.Error_State Read_Error IO) Char
- ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
-read_include = (do
+ , Stream s (R.State_Error Error_Read IO) Char
+ ) => ParsecT s (Context_Read c j) (R.State_Error Error_Read IO) ()
+read_include = (<?> "include") $ do
sourcepos <- R.getPosition
- filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
- read_context_including <- R.getState
- let journal_including = read_context_journal read_context_including
- let cwd = Path.takeDirectory (R.sourceName sourcepos)
- journal_file <- liftIO $ Path.abs cwd filename
- content <- do
- join $ liftIO $ Exception.catch
- (liftM return $ Text.IO.readFile journal_file)
- (return . R.fail_with "include reading" . Read_Error_reading_file journal_file)
- (journal_included, read_context_included) <- do
- liftIO $
- R.runParserT_with_Error
+ filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.newline <|> R.eof))
+ context_read_including <- R.getState
+ let journal_including = context_read_journal context_read_including
+ let cwd = FilePath.takeDirectory (R.sourceName sourcepos)
+ journal_file <- liftIO $ FilePath.path_absolute cwd filename
+ content <-
+ join $ liftIO $ Exn.catch
+ (return <$> Text.IO.readFile journal_file)
+ (return . R.parserFailWith "include reading" . Error_Read_reading_file journal_file)
+ (journal_included, context_read_included) <- do
+ lr <- liftIO $
+ R.runParserTWithError
(R.and_state $ read_journal_rec journal_file)
- read_context_including
- { read_context_journal=
+ context_read_including
+ { context_read_journal =
journal
{ journal_chart = journal_chart journal_including
, journal_amount_styles = journal_amount_styles journal_including
}
}
journal_file content
- >>= \x -> case x of
+ case lr of
Right ok -> return ok
- Left ko -> R.fail_with "include parsing" (Read_Error_including_file journal_file ko)
+ Left ko -> R.parserFailWith "include parsing" $
+ Error_Read_including_file journal_file ko
R.setState $
- read_context_included
- { read_context_journal=
+ context_read_included
+ { context_read_journal =
journal_including
- { journal_includes=
- journal_included{journal_files=[journal_file]} :
+ { journal_includes =
+ journal_included{ journal_files = [journal_file] } :
journal_includes journal_including
- , journal_chart=
+ , journal_chart =
journal_chart journal_included
- , journal_amount_styles=
+ , journal_amount_styles =
journal_amount_styles journal_included
}
}
- ) <?> "include"
-- * Read 'Chart'
read_chart ::
( Consable c j
- , Stream s (R.Error_State Read_Error IO) Char
- ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
-read_chart = (do
+ , Stream s (R.State_Error Error_Read IO) Char
+ ) => ParsecT s (Context_Read c j) (R.State_Error Error_Read IO) ()
+read_chart = (<?> "chart") $ do
-- sourcepos <- R.getPosition
acct <- read_account
read_hspaces
_ <- read_comments
- R.new_line
+ R.newline
tags_ <- R.many_separated
- (R.try (R.skipMany1 R.space_horizontal >> read_tag
+ (R.try (R.skipMany1 R.spaceHorizontal >> read_tag
<* read_hspaces <* read_comments))
- R.new_line
+ R.newline
R.skipMany R.space
let chart_accounts =
TreeMap.singleton acct $
- Account_Tags $
- Tag.from_List tags_
+ H.Account_Tags $
+ H.tag_from_List tags_
{-
let chart_tags =
foldl'
tags_
-}
ctx <- R.getState
- let j = read_context_journal ctx
+ let j = context_read_journal ctx
R.setState $
- ctx{read_context_journal=
+ ctx{context_read_journal=
j{journal_chart=
mappend
(journal_chart j)
- Chart.Chart
- { Chart.chart_accounts
- , Chart.chart_anchors = mempty
- -- , Chart.chart_tags
+ Chart
+ { chart_accounts
+ -- , chart_tags
}
}
}
- ) <?> "chart"
-- * Read 'Journal'
read_journal ::
( Consable c j
, Monoid j
- , Stream s (R.Error_State Read_Error IO) Char
+ , Stream s (R.State_Error Error_Read IO) Char
) => FilePath
- -> ParsecT s (Read_Context c j)
- (R.Error_State Read_Error IO)
+ -> ParsecT s (Context_Read c j)
+ (R.State_Error Error_Read IO)
(Journal j)
-read_journal filepath = (do
+read_journal filepath = (<?> "journal") $ do
currentLocalTime <- liftIO $
Time.utcToLocalTime
<$> Time.getCurrentTimeZone
<*> Time.getCurrentTime
let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
ctx <- R.getState
- R.setState $ ctx{read_context_year=currentLocalYear}
+ R.setState $ ctx{context_read_year=currentLocalYear}
read_journal_rec filepath
- ) <?> "journal"
read_journal_rec ::
( Consable c j
, Monoid j
- , Stream s (R.Error_State Read_Error IO) Char
+ , Stream s (R.State_Error Error_Read IO) Char
)
=> FilePath
- -> ParsecT s (Read_Context c j)
- (R.Error_State Read_Error IO)
+ -> ParsecT s (Context_Read c j)
+ (R.State_Error Error_Read IO)
(Journal j)
read_journal_rec journal_file = do
- last_read_time <- liftIO Date.now
+ last_read_time <- liftIO H.date_now
loop $
R.choice_try
[ jump_comment
, jump_transaction
, jump_chart
]
- journal_ <- read_context_journal <$> R.getState
+ journal_ <- context_read_journal <$> R.getState
return $
journal_
{ journal_files = [journal_file]
=> ParsecT s u m (ParsecT s u m ())
-> ParsecT s u m ()
loop r = do
- R.skipMany (read_hspaces >> R.new_line)
+ R.skipMany (read_hspaces >> R.newline)
_ <- join r
- R.skipMany (read_hspaces >> R.new_line)
+ R.skipMany (read_hspaces >> R.newline)
R.try (read_hspaces >> R.eof) <|> loop r
jump_comment ::
( Consable c j
, Stream s m Char
- , u ~ Read_Context c j
- , m ~ R.Error_State Read_Error IO
+ , u ~ Context_Read c j
+ , m ~ R.State_Error Error_Read IO
)
=> ParsecT s u m (ParsecT s u m ())
jump_comment = do
_cmts <- read_comments
{-
R.modifyState $ \ctx ->
- let j = read_context_journal ctx in
- ctx{read_context_journal=
+ let j = context_read_journal ctx in
+ ctx{context_read_journal=
j{journal_content=
- mcons (read_context_filter ctx) cmts $
+ mcons (context_read_filter ctx) cmts $
journal_content j}}
-}
return ()
( Consable c j
, Monoid j
, Stream s m Char
- , u ~ Read_Context c j
- , m ~ R.Error_State Read_Error IO
+ , u ~ Context_Read c j
+ , m ~ R.State_Error Error_Read IO
)
=> ParsecT s u m (ParsecT s u m ())
jump_directive = do
- let choice s = R.string s >> R.skipMany1 R.space_horizontal
- R.choice_try
- [ choice "Y" >> return read_default_year
- , choice "D" >> return read_default_unit_and_style
- , choice "!include" >> return read_include
- ] <?> "directive"
+ let choice s = R.string s >> R.skipMany1 R.spaceHorizontal
+ (<?> "directive") $
+ R.choice_try
+ [ choice "Y" >> return read_default_year
+ , choice "D" >> return read_default_unit_and_style
+ , choice "!include" >> return read_include
+ ]
jump_transaction ::
( Consable c j
, Stream s m Char
- , u ~ Read_Context c j
- , m ~ R.Error_State Read_Error IO
+ , u ~ Context_Read c j
+ , m ~ R.State_Error Error_Read IO
)
=> ParsecT s u m (ParsecT s u m ())
jump_transaction = do
return $ do
t <- read_transaction
R.modifyState $ \ctx ->
- let j = read_context_journal ctx in
- ctx{read_context_journal=
+ let j = context_read_journal ctx in
+ ctx{context_read_journal=
j{journal_content=
mcons
- (read_context_cons ctx $
- Chart.Charted (journal_chart j) t)
+ (context_read_cons ctx $
+ Charted (journal_chart j) t)
(journal_content j)}}
jump_chart ::
( Consable c j
, Stream s m Char
- , u ~ Read_Context c j
- , m ~ R.Error_State Read_Error IO
+ , u ~ Context_Read c j
+ , m ~ R.State_Error Error_Read IO
)
=> ParsecT s u m (ParsecT s u m ())
- jump_chart = do
+ jump_chart =
return read_chart
-- * Read
-read
+read_file
:: (Consable c j, Monoid j)
- => Read_Context c j
+ => Context_Read c j
-> FilePath
- -> ExceptT [R.Error Read_Error] IO (Journal j)
-read ctx path = do
- ExceptT $
- Exception.catch
- (liftM Right $ Text.IO.readFile path) $
+ -> ExceptT [R.Error Error_Read] IO (Journal j)
+read_file ctx path =
+ ExceptT
+ (Exn.catch
+ (Right <$> Text.IO.readFile path) $
\ko -> return $ Left $
[R.Error_Custom (R.initialPos path) $
- Read_Error_reading_file path ko]
- >>= liftIO . R.runParserT_with_Error
+ Error_Read_reading_file path ko])
+ >>= liftIO . R.runParserTWithError
(read_journal path) ctx path
>>= \x -> case x of
Left ko -> throwE $ ko
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Read.Test where
+
+import Control.Applicative (Applicative(..), (<*))
+import Control.Arrow (right)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Bool
+import Data.Data ()
+import Data.Decimal (DecimalRaw(..))
+import Data.Either (rights)
+import Data.Function (($), (.), id, const)
+import Data.Functor ((<$>))
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Map.Strict as Map
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Monoid (Monoid(..), (<>))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Time.Calendar as Time
+import qualified Data.Time.LocalTime as Time
+import Test.Tasty
+import Test.Tasty.HUnit
+import qualified Text.Parsec as R hiding
+ ( char
+ , anyChar
+ , crlf
+ , newline
+ , noneOf
+ , oneOf
+ , satisfy
+ , space
+ , spaces
+ , string
+ , tab
+ )
+import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
+import qualified Text.Parsec.Error.Custom as R
+import qualified Text.Parsec.Pos as R
+
+import qualified Hcompta as H
+import qualified Hcompta.Ledger as Ledger
+
+tests :: TestTree
+tests = testGroup "Read"
+ [ testGroup "read_date" $
+ (let (==>) (txt::Text) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParserWithError
+ (Ledger.read_date id Nothing <* R.eof) () "" txt]) in
+ [ "2000-01-01" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc ]
+ , "2000/01/01" ==> []
+ , "2000-01-01_12:34" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 12 34 0))
+ Time.utc ]
+ , "2000-01-01_12:34:56" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 12 34 56))
+ Time.utc ]
+ , "2000-01-01_12:34_CET" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 12 34 0))
+ (Time.TimeZone 60 True "CET") ]
+ , "2000-01-01_12:34+01:30" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 12 34 0))
+ (Time.TimeZone 90 False "+01:30") ]
+ , "2000-01-01_12:34:56_CET" ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 12 34 56))
+ (Time.TimeZone 60 True "CET") ]
+ , "2001-02-29" ==> []
+ ]) <>
+ (let (==>) (txt::Text, def) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParserWithError
+ (Ledger.read_date id (Just def) <* R.eof) () "" txt]) in
+ [ ("01-01", 2000) ==>
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc]
+ ])
+ , testGroup "read_account_section" $
+ let (==>) (txt::Text) b =
+ testCase (Text.unpack txt) $
+ (@?=) (rights [R.runParser
+ (Ledger.read_account_section <* R.eof) () "" txt])
+ [txt | b] in
+ [ "" ==> False
+ , "A" ==> True
+ , "AA" ==> True
+ , " " ==> False
+ , ":" ==> False
+ , "A:" ==> False
+ , ":A" ==> False
+ , "A " ==> False
+ , "A A" ==> True
+ , "A " ==> False
+ , "A\t" ==> False
+ , "A \n" ==> False
+ , "(A)A" ==> True
+ , "( )A" ==> True
+ , "(A) A" ==> True
+ , "[ ] A" ==> True
+ , "(A) " ==> False
+ , "(A)" ==> True
+ , "A(A)" ==> True
+ , "[A]A" ==> True
+ , "[A] A" ==> True
+ , "[A] " ==> False
+ , "[A]" ==> True
+ , testCase "\"A \"" $
+ rights [R.runParser
+ Ledger.read_account_section
+ () "" ("A "::Text)]
+ @?=
+ ["A"]
+ ]
+ , testGroup "read_account" $
+ let (==>) (txt::Text) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_account <* R.eof) () "" txt]) in
+ [ "" ==> []
+ , "A" ==> [ "A":|[] ]
+ , "A:" ==> []
+ , ":A" ==> []
+ , "A " ==> []
+ , " A" ==> []
+ , "A:B" ==> [ "A":|["B"] ]
+ , "A:B:C" ==> [ "A":|["B","C"] ]
+ , "Aa:Bbb:Cccc" ==> [ "Aa":|["Bbb", "Cccc"] ]
+ , "A a : B b b : C c c c" ==> [ "A a ":|[" B b b ", " C c c c"] ]
+ , "A: :C" ==> [ "A":|[" ", "C"] ]
+ , "A::C" ==> []
+ , "A:B:(C)" ==> [ "A":|["B", "(C)"] ]
+ ]
+ , testGroup "read_amount" $
+ let (==>) (txt::Text) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_amount <* R.eof) () "" txt]) in
+ [ "" ==> []
+ , "0" ==>
+ [( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , "00" ==>
+ [( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , "0." ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , ".0" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
+ , "0," ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , ",0" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
+ , "0_" ==> []
+ , "_0" ==> []
+ , "0.0" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
+ , "00.00" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
+ , "0,0" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
+ , "00,00" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
+ , "0_0" ==>
+ [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [1] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , "00_00" ==>
+ [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [2] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
+ , "0,000.00" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
+ , "0.000,00" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
+ , "1,000.00" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 100000 } )]
+ , "1.000,00" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 100000 } )]
+ , "1,000.00." ==> []
+ , "1.000,00," ==> []
+ , "1,000.00_" ==> []
+ , "123" ==>
+ [( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )]
+ , "1.2" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 12 } )]
+ , "1,2" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 12 } )]
+ , "12.34" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 1234 } )]
+ , "12,34" ==>
+ [( mempty { Ledger.amount_style_fractioning = Just ',' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 1234 } )]
+ , "1_2" ==>
+ [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [1] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 12 } )]
+ , "1_23" ==>
+ [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [2] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )]
+ , "1_23_456" ==>
+ [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 123456 } )]
+ , "1_23_456,7890_12345_678901" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2]
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
+ , "1_23_456.7890_12345_678901" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2]
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
+ , "1,23,456.7890_12345_678901" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3, 2]
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
+ , "1.23.456,7890_12345_678901" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3, 2]
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
+ , "123456_78901_2345.678_90_1" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6]
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [3, 2] }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 6 123456789012345678901 } )]
+ , "$1" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "$" } )]
+ , "1$" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "$" } )]
+ , "$ 1" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just True }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "$" } )]
+ , "1 $" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
+ , Ledger.amount_style_unit_spaced = Just True }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "$" } )]
+ , "-$1" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 (-1)
+ , Ledger.amount_unit = "$" } )]
+ , "\"4 2\"1" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "4 2" } )]
+ , "1\"4 2\"" ==>
+ [( mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 0 1
+ , Ledger.amount_unit = "4 2" } )]
+ , "$1.000,00" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3]
+ , Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 2 100000
+ , Ledger.amount_unit = "$" } )]
+ , "1.000,00$" ==>
+ [( mempty
+ { Ledger.amount_style_fractioning = Just ','
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3]
+ , Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
+ , Ledger.amount_style_unit_spaced = Just False }
+ , Ledger.amount
+ { Ledger.amount_quantity = Decimal 2 100000
+ , Ledger.amount_unit = "$" } )]
+ ]
+ , testGroup "read_posting_type" $
+ let (==>) a (ty, ac) =
+ let read (t::Text) = rights [R.runParser
+ (Ledger.read_account <* R.eof) () "" t] in
+ testCase (Text.unpack a) $
+ (@?=)
+ (Ledger.read_posting_type <$> read a)
+ (Ledger.Posting_Typed ty <$> read (fromMaybe a ac)) in
+ [ "A" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "(" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , ")" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "()" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "( )" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "(A)" ==> (Ledger.Posting_Type_Virtual, Just "A")
+ , "(A:B:C)" ==> (Ledger.Posting_Type_Virtual, Just "A:B:C")
+ , "A:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "(A):B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "A:(B):C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "A:B:(C)" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "[" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "]" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "[]" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "[ ]" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "[A]" ==> (Ledger.Posting_Type_Virtual_Balanced, Just "A")
+ , "[A:B:C]" ==> (Ledger.Posting_Type_Virtual_Balanced, Just "A:B:C")
+ , "A:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "[A]:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "A:[B]:C" ==> (Ledger.Posting_Type_Regular, Nothing)
+ , "A:B:[C]" ==> (Ledger.Posting_Type_Regular, Nothing)
+ ]
+ , testGroup "read_comment" $
+ let (==>) (txt::Text, end) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_comment <* end) () "" txt]) in
+ [ ("; some comment", R.eof) ==> [" some comment"]
+ , ("; some comment \n", R.newline <* R.eof) ==> [ " some comment " ]
+ , ("; some comment \r\n", R.string "\r\n" <* R.eof) ==> [ " some comment " ]
+ ]
+ , testGroup "read_comments" $
+ let (==>) (txt::Text, end) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_comments <* end) () "" txt]) in
+ [ ("; some comment\n ; some other comment", R.eof) ==> [ [" some comment", " some other comment"] ]
+ , ("; some comment \n", R.string "\n" <* R.eof) ==> [ [" some comment "] ]
+ ]
+ , testGroup "read_tag_value" $
+ let (==>) (txt::Text, end) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_tag_value <* end) () "" txt]) in
+ [ (",", R.eof) ==> [","]
+ , (",\n", R.char '\n' <* R.eof) ==> [","]
+ , (",x", R.eof) ==> [",x"]
+ , (",x:", R.string ",x:" <* R.eof) ==> [""]
+ , ("v, v, n:", R.string ", n:" <* R.eof) ==> ["v, v"]
+ ]
+ , testGroup "read_tag" $
+ let (==>) (txt::Text, end) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_tag <* end) () "" txt]) in
+ [ ("Name:" , R.eof) ==> [ ("Name":|[], "") ]
+ , ("Name:Value" , R.eof) ==> [ ("Name":|[], "Value") ]
+ , ("Name:Value\n" , R.string "\n" <* R.eof) ==> [ ("Name":|[], "Value") ]
+ , ("Name:Val ue" , R.eof) ==> [ ("Name":|[], "Val ue") ]
+ , ("Name:," , R.eof) ==> [ ("Name":|[], ",") ]
+ , ("Name:Val,ue" , R.eof) ==> [ ("Name":|[], "Val,ue") ]
+ , ("Name:Val,ue:" , R.string ",ue:" <* R.eof) ==> [ ("Name":|[], "Val") ]
+ , ("Name:Val,ue :", R.eof) ==> [ ("Name":|[], "Val,ue :") ]
+ ]
+ , testGroup "read_tags" $
+ let (==>) (txt::Text) =
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParser
+ (Ledger.read_tags <* R.eof) () "" txt]) .
+ pure . Map.fromList in
+ [ "Name:" ==> [ ("Name":|[], [""]) ]
+ , "Name:," ==> [ ("Name":|[], [","]) ]
+ , "Name:,Name:" ==> [ ("Name":|[], ["", ""]) ]
+ , "Name:,Name2:" ==>
+ [ ("Name":|[], [""])
+ , ("Name2":|[], [""])
+ ]
+ , "Name: , Name2:" ==>
+ [ ("Name":|[], [" "])
+ , ("Name2":|[], [""])
+ ]
+ , "Name:,Name2:,Name3:" ==>
+ [ ("Name":|[], [""])
+ , ("Name2":|[], [""])
+ , ("Name3":|[], [""])
+ ]
+ , "Name:Val ue,Name2:V a l u e,Name3:V al ue" ==>
+ [ ("Name":|[], ["Val ue"])
+ , ("Name2":|[], ["V a l u e"])
+ , ("Name3":|[], ["V al ue"])
+ ]
+ ]
+ , testGroup "read_posting" $
+ let (==>) (txt::Text) =
+ let context_read =
+ ( Ledger.context_read (const ()) Ledger.journal
+ ::Ledger.Context_Read () ()) in
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParserWithError
+ (Ledger.read_posting <* R.eof) context_read "" txt]) .
+ ((\p -> Ledger.Posting_Typed Ledger.Posting_Type_Regular
+ p { Ledger.posting_sourcepos = R.newPos "" 1 1 }) <$>) in
+ [ " A:B:C" ==> [Ledger.posting ("A":|["B", "C"])]
+ , "A:B:C" ==> []
+ , " !A:B:C" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_status = True }]
+ , " *A:B:C" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_status = True }]
+ , " A:B:C $1" ==> [Ledger.posting ("A":|["B", "C $1"])]
+ , " A:B:C $1" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [("$", 1)] }]
+ , " A:B:C $1 + 1€" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [("$", 1), ("€", 1)] }]
+ , " A:B:C $1 + 1$" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [("$", 2)] }]
+ , " A:B:C $1 + 1$ + 1$" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [("$", 3)] }]
+ , " A:B:C ; some comment" ==> [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList []
+ , Ledger.posting_comments = [" some comment"] }]
+ , " A:B:C ; some comment\n ; some other comment" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList []
+ , Ledger.posting_comments = [" some comment", " some other comment"] }]
+ , " A:B:C $1 ; some comment" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [("$", 1)]
+ , Ledger.posting_comments = [" some comment"] }]
+ , " A:B:C ; N:V" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" N:V"]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List [ ("N":|[], "V") ] }]
+ , " A:B:C ; some comment N:V" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" some comment N:V"]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List [ ("N":|[], "V") ] }]
+ , " A:B:C ; some comment N:V v, N2:V2 v2" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" some comment N:V v, N2:V2 v2"]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List
+ [ ("N":|[], "V v")
+ , ("N2":|[], "V2 v2") ] }]
+ , " A:B:C ; N:V\n ; N:V2" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" N:V", " N:V2"]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List
+ [ ("N":|[], "V")
+ , ("N":|[], "V2")
+ ] }]
+ , " A:B:C ; N:V\n ; N2:V" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" N:V", " N2:V"]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List
+ [ ("N":|[], "V")
+ , ("N2":|[], "V")
+ ] }]
+ , " A:B:C ; date:2001-01-01" ==>
+ [(Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_comments = [" date:2001-01-01"]
+ , Ledger.posting_dates =
+ [ Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2001 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ ]
+ , Ledger.posting_tags = H.Posting_Tags $
+ H.tag_from_List
+ [ ("date":|[], "2001-01-01") ] }]
+ , testCase " (A:B:C) = Right (A:B:C)" $
+ rights [R.runParserWithError
+ (Ledger.read_posting <* R.eof)
+ ( Ledger.context_read (const ()) Ledger.journal
+ ::Ledger.Context_Read () ())
+ "" (" (A:B:C)"::Text)] @?=
+ [Ledger.Posting_Typed
+ Ledger.Posting_Type_Virtual
+ (Ledger.posting ("A":|["B", "C"]))]
+ , testCase " [A:B:C] = Right [A:B:C]" $
+ rights [R.runParserWithError
+ (Ledger.read_posting <* R.eof)
+ ( Ledger.context_read (const ()) Ledger.journal
+ ::Ledger.Context_Read () ())
+ "" (" [A:B:C]"::Text)] @?=
+ [Ledger.Posting_Typed
+ Ledger.Posting_Type_Virtual_Balanced
+ (Ledger.posting ("A":|["B", "C"]))]
+ ]
+ , testGroup "read_transaction" $
+ let (==>) (txt::Text) =
+ let context_read =
+ ( Ledger.context_read (const ()) Ledger.journal
+ ::Ledger.Context_Read () ()) in
+ testCase (Text.unpack txt) .
+ (@?=) (rights [R.runParserWithError
+ (Ledger.read_transaction <* R.eof) context_read "" txt]) .
+ ((\t -> t { Ledger.transaction_sourcepos = R.newPos "" 1 1 }) <$>) in
+ [ "2000-01-01 some wording\n A:B:C $1\n a:b:c" ==>
+ [Ledger.transaction
+ { Ledger.transaction_dates=
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording="some wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 2 1 }
+ , (Ledger.posting ("a":|["b", "c"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 3 1 }
+ ]
+ }]
+ , "2000-01-01 some wording\n A:B:C $1\n a:b:c\n" ==> []
+ , "2000-01-01 some wording ; some comment\n ; some other;comment\n ; some Tag:\n ; some last comment\n A:B:C $1\n a:b:c" ==>
+ [Ledger.transaction
+ { Ledger.transaction_comments_after =
+ [ " some comment"
+ , " some other;comment"
+ , " some Tag:"
+ , " some last comment"
+ ]
+ , Ledger.transaction_dates=
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording="some wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 5 1 }
+ , (Ledger.posting ("a":|["b", "c"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 6 1 } ]
+ , Ledger.transaction_tags = H.Transaction_Tags $
+ H.tag_from_List [ ("Tag":|[], "") ] }]
+ ]
+ , testGroup "read_journal"
+ [ testCase "2000-01-01 1° wording\\n A:B:C $1\\n a:b:c\\n2000-01-02 2° wording\\n A:B:C $1\\n x:y:z" $ do
+ jnl <- liftIO $
+ R.runParserTWithError
+ (Ledger.read_journal "" {-<* R.eof-})
+ ( Ledger.context_read id Ledger.journal
+ ::Ledger.Context_Read (Ledger.Charted Ledger.Transaction)
+ [Ledger.Charted Ledger.Transaction])
+ "" ("2000-01-01 1° wording\n A:B:C $1\n a:b:c\n2000-01-02 2° wording\n A:B:C $1\n x:y:z"::Text)
+ ((\j -> j{Ledger.journal_last_read_time=H.date_epoch}) <$> rights [jnl])
+ @?=
+ [Ledger.journal
+ { Ledger.journal_content =
+ Ledger.Charted mempty <$>
+ [ Ledger.transaction
+ { Ledger.transaction_dates=
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 02)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording="2° wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 5 1
+ }
+ , (Ledger.posting ("x":|["y", "z"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 6 1
+ }
+ ]
+ , Ledger.transaction_sourcepos = R.newPos "" 4 1
+ }
+ , Ledger.transaction
+ { Ledger.transaction_dates=
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording="1° wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 2 1
+ }
+ , (Ledger.posting ("a":|["b", "c"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 3 1
+ }
+ ]
+ , Ledger.transaction_sourcepos = R.newPos "" 1 1
+ }
+ ]
+ , Ledger.journal_files = [""]
+ , Ledger.journal_amount_styles = Ledger.Amount_Styles $ Map.fromList
+ [ ( Ledger.Unit "$"
+ , mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ )
+ ]
+ }
+ ]
+ ]
+ , testGroup "read_journal" $
+ let (==>) (txt::Text) e =
+ testCase (Text.unpack txt) $ do
+ jnl <-
+ liftIO $
+ right (\j -> j{Ledger.journal_last_read_time=H.date_epoch}) <$>
+ R.runParserTWithError
+ (Ledger.read_journal "" {-<* R.eof-})
+ ( Ledger.context_read id Ledger.journal
+ ::Ledger.Context_Read (Ledger.Charted Ledger.Transaction)
+ [Ledger.Charted Ledger.Transaction])
+ "" (txt::Text)
+ (@?=) (rights [jnl]) e in
+ [ Text.unlines
+ [ "2000-01-01 1° wording"
+ , " A:B:C $1"
+ , " a:b:c"
+ , "2000-01-02 2° wording"
+ , " A:B:C $1"
+ , " x:y:z"
+ ] ==>
+ [ Ledger.journal
+ { Ledger.journal_content =
+ Ledger.Charted mempty <$>
+ [ Ledger.transaction
+ { Ledger.transaction_dates =
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 02)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording ="2° wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 5 1
+ }
+ , (Ledger.posting ("x":|["y", "z"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 6 1
+ }
+ ]
+ , Ledger.transaction_sourcepos = R.newPos "" 4 1
+ }
+ , Ledger.transaction
+ { Ledger.transaction_dates =
+ ( Time.zonedTimeToUTC $
+ Time.ZonedTime
+ (Time.LocalTime
+ (Time.fromGregorian 2000 01 01)
+ (Time.TimeOfDay 0 0 0))
+ Time.utc
+ , [] )
+ , Ledger.transaction_wording = "1° wording"
+ , Ledger.transaction_postings = Ledger.postings_by_account
+ [ (Ledger.posting ("A":|["B", "C"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 2 1
+ }
+ , (Ledger.posting ("a":|["b", "c"]))
+ { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
+ , Ledger.posting_sourcepos = R.newPos "" 3 1
+ }
+ ]
+ , Ledger.transaction_sourcepos = R.newPos "" 1 1
+ }
+ ]
+ , Ledger.journal_files = [""]
+ , Ledger.journal_amount_styles = Ledger.Amount_Styles $ Map.fromList
+ [ ( Ledger.Unit "$"
+ , mempty
+ { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
+ , Ledger.amount_style_unit_spaced = Just False }
+ )
+ ]
+ }
+ ]
+ ]
+ ]
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Test where
+
+import Data.Function (($))
+import System.IO (IO)
+import Test.Tasty
+
+import qualified Read.Test as Read
+import qualified Write.Test as Write
+
+main :: IO ()
+main =
+ defaultMain $
+ testGroup "Ledger"
+ [ Read.tests
+ , Write.tests
+ ]
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hcompta.Ledger.Transaction where
+
+import Control.DeepSeq (NFData(..))
+import Data.Bool
+import Data.Data (Data(..))
+import Data.Eq (Eq(..))
+import Data.Function (($), (.), id)
+import Data.Functor.Compose (Compose(..))
+import qualified Data.List as List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Monoid (Monoid(..))
+import Data.Text (Text)
+import Data.Tuple (fst)
+import Data.Typeable (Typeable)
+import Prelude (flip, seq)
+import Text.Parsec.Pos (SourcePos, initialPos)
+import Text.Show (Show)
+
+import qualified Hcompta as H
+
+import Hcompta.Ledger.Account
+import Hcompta.Ledger.Posting
+import Hcompta.Ledger.Chart
+
+-- * Type 'Transaction'
+
+data Transaction
+ = Transaction
+ { transaction_code :: Code
+ , transaction_comments_before :: [Comment]
+ , transaction_comments_after :: [Comment]
+ , transaction_dates :: (H.Date, [H.Date])
+ , transaction_postings :: Map Account [Posting]
+ , transaction_sourcepos :: SourcePos
+ , transaction_status :: Status
+ , transaction_tags :: H.Transaction_Tags
+ , transaction_wording :: Wording
+ } deriving (Data, Eq, Show, Typeable)
+
+transaction :: Transaction
+transaction =
+ Transaction
+ { transaction_code = ""
+ , transaction_comments_after = []
+ , transaction_comments_before = []
+ , transaction_dates = (H.date_epoch, [])
+ , transaction_postings = mempty
+ , transaction_sourcepos = initialPos ""
+ , transaction_status = False
+ , transaction_tags = mempty
+ , transaction_wording = ""
+ }
+
+instance NFData Transaction where
+ rnf Transaction{..} =
+ rnf transaction_code `seq`
+ rnf transaction_comments_before `seq`
+ rnf transaction_comments_after `seq`
+ rnf transaction_dates `seq`
+ rnf transaction_postings `seq`
+ -- rnf transaction_sourcepos `seq`
+ rnf transaction_status `seq`
+ rnf transaction_tags `seq`
+ rnf transaction_wording
+
+-- Transaction
+instance H.Transaction Transaction where
+ type Transaction_Posting Transaction = Posting
+ type Transaction_Postings Transaction = Compose (Map Account) [] Posting
+ transaction_date = fst . transaction_dates
+ transaction_description = transaction_wording
+ transaction_postings = Compose . transaction_postings
+ transaction_tags = transaction_tags
+instance H.Transaction (Charted Transaction) where
+ type Transaction_Posting (Charted Transaction) = H.Transaction_Posting Transaction
+ type Transaction_Postings (Charted Transaction) = H.Transaction_Postings Transaction
+ transaction_date = H.transaction_date . charted
+ transaction_description = H.transaction_description . charted
+ transaction_postings = H.transaction_postings . charted
+ transaction_tags = H.transaction_tags . charted
+
+-- Journal
+instance H.Journal_Transaction Transaction
+instance H.Journal_Transaction (Charted Transaction)
+
+-- Stats
+instance H.Stats_Transaction Transaction where
+ stats_transaction_postings_count = Map.size . transaction_postings
+instance H.Stats_Transaction (Charted Transaction) where
+ stats_transaction_postings_count = H.stats_transaction_postings_count . charted
+
+-- GL
+instance H.GL_Transaction Transaction where
+ type GL_Transaction_Line Transaction = Transaction
+ gl_transaction_line = id
+instance H.GL_Transaction (Charted Transaction) where
+ type GL_Transaction_Line (Charted Transaction) = H.GL_Transaction_Line Transaction
+ gl_transaction_line = H.gl_transaction_line . charted
+
+-- | Return a 'Map' associating
+-- the given 'Transaction's with their respective 'Date'.
+transaction_by_date :: [Transaction] -> (Compose (Map H.Date) []) Transaction
+transaction_by_date =
+ Compose .
+ Map.fromListWith (flip mappend) .
+ List.map (\t -> (fst $ transaction_dates t, [t]))
+
+-- ** Type 'Wording'
+
+type Wording = Text
+
+-- ** Type 'Date'
+
+type Date = H.Date
+
+-- ** Type 'Code'
+
+type Code = Text
+
+-- ** Type 'Status'
+type Status = Bool
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-module Hcompta.Format.Ledger.Write where
+module Hcompta.Ledger.Write where
-import Control.Applicative ((<$>), (<*>), (<*))
-import Control.Monad (Monad(..))
+import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
+import Control.Applicative (Applicative(..), (<*))
import Data.Bool
import Data.Char (Char, isSpace)
import qualified Data.Char as Char
+import Data.Decimal
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Maybe (Maybe(..), maybe, fromMaybe)
+import GHC.Exts (Int(..))
import qualified Data.Foldable
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip, id)
-import Data.Functor (Functor(..))
+import Data.Functor (Functor(..), (<$>))
import qualified Data.Functor.Compose
+import System.IO (IO, Handle)
+import GHC.Integer.Logarithms (integerLogBase#)
import Data.List ((++))
import qualified Data.List as List
import qualified Data.List.NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
-import Data.Monoid (Monoid(..))
+import Data.Maybe (Maybe(..), maybe, fromMaybe)
+import Control.Monad (Monad(..))
+import Data.Monoid (Monoid(..), (<>))
import Data.Ord (Ord(..))
-import Data.Tuple (fst)
-import Data.Decimal
+import Text.Parsec (Stream, ParsecT)
+import qualified Text.Parsec as R hiding (satisfy, char)
+import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Time.LocalTime as Time
-import GHC.Exts (Int(..))
-import GHC.Integer.Logarithms (integerLogBase#)
-import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
-import System.IO (IO, Handle)
-import Text.Parsec (Stream, ParsecT)
-import qualified Text.Parsec as R hiding (satisfy, char)
+import qualified Data.TreeMap.Strict as TreeMap
+import Data.Tuple (fst)
-import Hcompta.Account (Account_Tags(..))
-import qualified Hcompta.Account as Account
-import qualified Hcompta.Amount as Amount
-import qualified Hcompta.Chart as Chart
-import qualified Hcompta.Unit as Unit
-import Hcompta.Date (Date)
-import qualified Hcompta.Date as Date
-import Hcompta.Lib.Leijen (Doc, (<>))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import Hcompta.Tag (Tag, Tags(..))
+import qualified Hcompta as H
+import Text.WalderLeijen.ANSI.Text (Doc)
+import qualified Text.WalderLeijen.ANSI.Text as W
-import Hcompta.Format.Ledger
-import Hcompta.Format.Ledger.Read
+import Hcompta.Ledger.Account
+import Hcompta.Ledger.Amount
+import Hcompta.Ledger.Chart
+import Hcompta.Ledger.Posting
+import Hcompta.Ledger.Transaction
+import Hcompta.Ledger.Journal
+import Hcompta.Ledger.Read
-- * Write 'Date'
-write_date :: Date -> Doc
-write_date dat = do
- let (y, mo, d) = Date.gregorian dat
- (if y == 0 then W.empty else W.integer y <> sep '-') <> do
- int2 mo <> do
- sep '-' <> int2 d <> do
- (case Date.tod dat of
+write_date :: H.Date -> Doc
+write_date dat =
+ let (y, mo, d) = H.date_gregorian dat in
+ (if y == 0 then W.empty else W.integer y <> sep '-') <>
+ int2 mo <>
+ sep '-' <> int2 d <>
+ (case H.date_tod dat of
Time.TimeOfDay 0 0 0 -> W.empty
Time.TimeOfDay h m s ->
- sep '_' <> int2 h <> do
- sep ':' <> int2 m <> do
+ sep '_' <> int2 h <>
+ sep ':' <> int2 m <>
(case s of
0 -> W.empty
- _ -> sep ':' <> do
- (if s < 10 then W.char '0' else W.empty) <> do
- W.strict_text $ Text.pack $ show $ (truncate s::Integer)))
+ _ -> sep ':' <>
+ (if s < 10 then W.char '0' else W.empty) <>
+ W.strict_text (Text.pack $ show $ (truncate s::Integer))))
-- (case tz_min of
-- 0 -> W.empty
-- _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
sep :: Char -> Doc
sep = W.bold . W.dullblack . W.char
-write_date_length :: Date -> Int
+write_date_length :: H.Date -> Int
write_date_length dat = do
- let (y, _, _) = Date.gregorian dat
+ let (y, _, _) = H.date_gregorian dat
(case y of
0 -> 0
_ ->
+ 2 -- month
+ 1 -- -
+ 2 -- dom
- + (case Date.tod dat of
+ + (case H.date_tod dat of
Time.TimeOfDay 0 0 0 -> 0
Time.TimeOfDay _ _ s ->
1 -- _
case type_ of
Posting_Type_Regular -> account_
Posting_Type_Virtual -> \acct ->
- W.char read_posting_type_virtual_begin <> do
- account_ acct <> do
+ W.char read_posting_type_virtual_begin <>
+ account_ acct <>
W.char read_posting_type_virtual_end
Posting_Type_Virtual_Balanced -> \acct ->
- W.char read_posting_type_virtual_balanced_begin <> do
- account_ acct <> do
+ W.char read_posting_type_virtual_balanced_begin <>
+ account_ acct <>
W.char read_posting_type_virtual_balanced_end
where
account_ :: Account -> Doc
(W.bold $ W.dullblack $ W.char read_account_section_sep)
(Data.List.NonEmpty.map write_account_section acct)
-write_account_section :: Account.Account_Section Account -> Doc
+write_account_section :: Account_Section -> Doc
write_account_section = W.strict_text
write_account_length :: Posting_Type -> Account -> Int
, amount_style_unit_spaced
})
, amt ) =
- let unt = Amount.amount_unit amt in
+ let unt = H.amount_unit amt in
case amount_style_unit_side of
Just Amount_Style_Side_Left ->
write_unit unt <>
case amount_style_unit_spaced of
- Just True | unt /= Unit.unit_empty -> W.space
+ Just True | unt /= H.unit_empty -> W.space
_ -> W.empty
_ -> W.empty
- <> write_quantity (sty, Amount.amount_quantity amt)
+ <> write_quantity (sty, H.amount_quantity amt)
<> case amount_style_unit_side of
(Just Amount_Style_Side_Right) ->
(case amount_style_unit_spaced of
- Just True | unt /= Unit.unit_empty -> W.space
+ Just True | unt /= H.unit_empty -> W.space
_ -> W.empty) <>
write_unit unt
Nothing ->
(case amount_style_unit_spaced of
- Just True | unt /= Unit.unit_empty -> W.space
+ Just True | unt /= H.unit_empty -> W.space
_ -> W.empty) <>
write_unit unt
_ -> W.empty
write_amount_length :: Amount_Styled Amount -> Int
write_amount_length (sty@(Amount_Style { amount_style_unit_spaced }), amt) =
- let unt = Amount.amount_unit amt in
+ let unt = H.amount_unit amt in
write_unit_length unt
+ (case amount_style_unit_spaced of
- { Just True | unt /= Unit.unit_empty -> 1; _ -> 0 })
- + write_quantity_length sty (Amount.amount_quantity amt)
+ { Just True | unt /= H.unit_empty -> 1; _ -> 0 })
+ + write_quantity_length sty (H.amount_quantity amt)
-- ** Write 'Amount's
(if W.is_empty doc
then doc
else doc <> W.space <>
- (W.bold $ W.yellow $ W.char read_amount_sep) <>
+ W.bold (W.yellow $ W.char read_amount_sep) <>
W.space) <>
- (write_amount $
- amount_styled styles $
- Amount unit qty))
+ write_amount (amount_styled styles $ Amount unit qty))
W.empty
write_amounts_length :: Amount_Styles -> Map Unit Quantity -> Int
write_unit :: Unit -> Doc
write_unit u =
- let t = Unit.unit_text u in
+ let t = H.unit_text u in
W.yellow $
if Text.all
(\c -> case Char.generalCategory c of
write_unit_length :: Unit -> Int
write_unit_length u =
- let t = Unit.unit_text u in
+ let t = H.unit_text u in
Text.length t +
if Text.all
(\c -> case Char.generalCategory c of
let Decimal e n = qty
let num = show $ abs $ n
let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
- case e == 0 of
- True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
- False -> do
- let num_len = List.length num
+ if e == 0
+ then sign <> W.bold (W.blue $ W.strict_text $ Text.pack num)
+ else
+ let num_len = List.length num in
let padded =
List.concat
[ List.replicate (fromIntegral e + 1 - num_len) '0'
, num
-- , replicate (fromIntegral precision - fromIntegral e) '0'
- ]
- let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
+ ] in
+ let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded in
let default_fractioning =
List.head $
del_grouping_sep amount_style_grouping_integral $
del_grouping_sep amount_style_grouping_fractional $
- ['.', ',']
- sign <> do
- W.bold $ W.blue $ do
+ ['.', ','] in
+ sign <>
+ W.bold (W.blue $
W.text (TL.pack $ maybe id
(\g -> List.reverse . group g . List.reverse)
- amount_style_grouping_integral $ int) <> do
- (W.yellow $ W.char (fromMaybe default_fractioning amount_style_fractioning)) <> do
- W.text (TL.pack $ maybe id group amount_style_grouping_fractional frac)
+ amount_style_grouping_integral $ int) <>
+ W.yellow (W.char (fromMaybe default_fractioning amount_style_fractioning)) <>
+ W.text (TL.pack $ maybe id group amount_style_grouping_fractional frac))
where
group :: Amount_Style_Grouping -> [Char] -> [Char]
group (Amount_Style_Grouping sep sizes_) =
else loop 0 num_len sizes_
where
loop :: Int -> Int -> [Int] -> Int
- loop pad len =
- \x -> case x of
+ loop pad len x =
+ case x of
[] -> 0
sizes@[size] ->
let l = len - size in
write_comment :: Comment -> Doc
write_comment com =
- W.cyan $ do
+ W.cyan $
W.char read_comment_prefix
<> (case Text.uncons com of
Just (c, _) | not $ Data.Char.isSpace c -> W.space
_ -> W.empty)
- <> do W.if_color colorize (W.strict_text com)
+ <> W.if_color colorize (W.strict_text com)
where
colorize :: Doc
colorize =
ns <- R.many $ R.satisfy
(\c -> c /= read_tag_value_sep
&& not (Data.Char.isSpace c))
- sh <- R.space_horizontal
+ sh <- R.spaceHorizontal
return (ns ++ [sh])
((W.text $ TL.pack $ mconcat pre) <>) <$> tags <* R.eof)
() "" com of
Left _ -> W.strict_text com
Right doc -> doc
tags :: Stream s m Char => ParsecT s u m Doc
- tags = do
+ tags =
(<>)
<$> tag_
<*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
tag_sep :: Stream s m Char => ParsecT s u m Doc
tag_sep = do
s <- R.char read_tag_sep
- sh <- R.many R.space_horizontal
+ sh <- R.many R.spaceHorizontal
return $
- do W.cyan $ W.char s
- <> do W.text $ TL.pack sh
+ W.cyan (W.char s) <>
+ W.text (TL.pack sh)
tag_ :: Stream s m Char => ParsecT s u m Doc
tag_ = do
(p, v) <- read_tag
return $
- foldMap (\s -> W.dullyellow (W.strict_text s) <> do
- W.bold $ W.dullblack $ W.char read_tag_value_sep) p <>
- (W.red $ W.strict_text v)
+ foldMap (\s -> W.dullyellow (W.strict_text s) <>
+ W.bold (W.dullblack $ W.char read_tag_value_sep)) p <>
+ W.red (W.strict_text v)
write_comments :: Doc -> [Comment] -> Doc
write_comments prefix =
-- * Write 'Tag'
-write_tag :: Tag -> Doc
+write_tag :: H.Tag -> Doc
write_tag (p, v) =
- foldMap (\s -> W.dullyellow (W.strict_text s) <> W.char read_tag_value_sep) p <>
- (W.dullred $ W.strict_text v)
+ foldMap (\s ->
+ W.dullyellow (W.strict_text s) <>
+ W.char read_tag_value_sep) p <>
+ W.dullred (W.strict_text v)
-- * Write 'Posting'
-- , posting_dates
, posting_status
-- , posting_tags
- } = do
- let type_ = posting_type p
- write_indent <> do
- write_status posting_status <> do
- case Map.null posting_amounts of
- True -> write_account type_ posting_account
- False ->
+ } =
+ let type_ = posting_type p in
+ write_indent <>
+ write_status posting_status <>
+ if Map.null posting_amounts
+ then write_account type_ posting_account
+ else
let len_acct = write_account_length type_ posting_account in
let len_amts = write_amounts_length styles posting_amounts in
- write_account type_ posting_account <> do
- W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
+ write_account type_ posting_account <>
+ W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <>
write_amounts styles posting_amounts
<> (case posting_comments of
[] -> W.empty
[c] -> W.space <> write_comment c
- _ -> W.line <> do write_comments (write_indent <> W.space) posting_comments)
+ _ -> W.line <> write_comments (write_indent <> W.space) posting_comments)
write_indent :: Doc
write_indent = W.space <> W.space
write_status :: Status -> Doc
-write_status = \x -> case x of
- True -> W.char '!'
- False -> W.empty
+write_status s =
+ if s
+ then W.char '!'
+ else W.empty
-- ** Type 'Posting_Lengths'
, transaction_status
-- , transaction_tags
, transaction_wording
- } = do
+ } =
(case transaction_comments_before of
[] -> W.empty
- _ -> write_comments W.space transaction_comments_before <> W.line) <> do
- (W.hcat $
- List.intersperse
+ _ -> write_comments W.space transaction_comments_before <> W.line) <>
+ W.hcat
+ (List.intersperse
(W.char read_date_ymd_sep)
- (write_date <$> (first_date:dates))) <> do
- (case transaction_status of
- True -> W.space <> write_status transaction_status
- False -> W.empty) <> do
- write_code transaction_code <> do
+ (write_date <$> (first_date:dates))) <>
+ (if transaction_status
+ then W.space <> write_status transaction_status
+ else W.empty) <>
+ write_code transaction_code <>
(case transaction_wording of
"" -> W.empty
- _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
- W.line <> do
+ _ -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
+ W.line <>
(case transaction_comments_after of
[] -> W.empty
- _ -> write_comments W.space transaction_comments_after <> W.line) <> do
+ _ -> write_comments W.space transaction_comments_after <> W.line) <>
W.intercalate W.line
(W.vsep . fmap (write_posting styles posting_lengths_))
transaction_postings
<> W.line
write_code :: Code -> Doc
-write_code = \x -> case x of
+write_code c =
+ case c of
"" -> W.empty
t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
styles
Transaction
{ transaction_postings
- } posting_lengths = do
+ } posting_lengths =
List.foldl'
(flip $ write_postings_lengths styles)
posting_lengths
write_chart :: Chart -> Doc
write_chart =
TreeMap.foldl_with_Path
- (\doc acct (Account_Tags (Tags ca)) ->
+ (\doc acct (H.Account_Tags (H.Tags ca)) ->
doc <>
write_account Posting_Type_Regular acct <> W.line <>
Map.foldlWithKey
W.empty
ca
) W.empty .
- Chart.chart_accounts
+ chart_accounts
-- * Type 'Write_Style'
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Write.Test where
+
+import Control.Applicative (Applicative(..), (<*))
+import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Data ()
+import Data.Decimal (DecimalRaw(..))
+import Data.Either (either, rights)
+import Data.Function (($), (.), const, id)
+import Data.Functor ((<$>))
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
+import Test.Tasty
+import Test.Tasty.HUnit
+import qualified Text.Parsec as R hiding
+ ( char
+ , anyChar
+ , crlf
+ , newline
+ , noneOf
+ , oneOf
+ , satisfy
+ , space
+ , spaces
+ , string
+ , tab
+ )
+import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
+import qualified Text.Parsec.Error.Custom as R
+-- import Text.Show (Show(..))
+
+import qualified Hcompta as H
+import qualified Hcompta.Ledger as Ledger
+import qualified Hcompta.Ledger.Lib.Parsec as R
+
+tests :: TestTree
+tests = testGroup "Write"
+ [ testGroup "write_date" $
+ let (==>) (txt::Text) e =
+ testCase (Text.unpack txt) $
+ (@?=)
+ (Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True } .
+ Ledger.write_date <$>
+ rights [R.runParserWithError
+ (Ledger.read_date id Nothing <* R.eof) () "" txt])
+ [e] in
+ [ testCase "date_epoch" $
+ Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True }
+ (Ledger.write_date H.date_epoch)
+ @?= "1970-01-01"
+ , "2000-01-01" ==> "2000-01-01"
+ , "2000-01-01_12:34:51_CET" ==> "2000-01-01_11:34:51"
+ , "2000-01-01_12:34:51+01:10" ==> "2000-01-01_11:24:51"
+ , "2000-01-01_12:34:51-01:10" ==> "2000-01-01_13:44:51"
+ , "2000-01-01_01:02:03" ==> "2000-01-01_01:02:03"
+ , "2000-01-01_01:02" ==> "2000-01-01_01:02"
+ , "2000-01-01_01:00" ==> "2000-01-01_01:00"
+ ]
+ , testGroup "write_amount" $
+ let (<==) (txt::Text) e =
+ testCase (Text.unpack txt) $
+ (@?=)
+ (Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True } $
+ Ledger.write_amount e)
+ (TL.fromStrict txt) in
+ [ "0" <==
+ ( mempty
+ , Ledger.amount )
+ , "0.00" <==
+ ( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )
+ , "123" <==
+ ( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )
+ , "-123" <==
+ ( mempty
+ , Ledger.amount { Ledger.amount_quantity = Decimal 0 (- 123) } )
+ , "12.3" <==
+ ( mempty { Ledger.amount_style_fractioning = Just '.' }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 1 123 } )
+ , "1,234.56" <==
+ ( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3]
+ }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 2 123456 })
+ , "123,456,789,01,2.3456789" <==
+ ( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [1, 2, 3]
+ }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 7 1234567890123456789 } )
+ , "1234567.8_90_123_456_789" <==
+ ( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [1, 2, 3]
+ }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 12 1234567890123456789 })
+ , "1,2,3,4,5,6,7,89,012.3456789" <==
+ ( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3, 2, 1]
+ }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 7 1234567890123456789 })
+ , "1234567.890_12_3_4_5_6_7_8_9" <==
+ ( mempty
+ { Ledger.amount_style_fractioning = Just '.'
+ , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [3, 2, 1]
+ }
+ , Ledger.amount { Ledger.amount_quantity = Decimal 12 1234567890123456789 })
+ ]
+ , testGroup "write_amount_length" $
+ let (==>) (txt::Text) =
+ testCase (Text.unpack txt) $
+ (@?=)
+ (Ledger.write_amount_length <$>
+ rights [R.runParser (Ledger.read_amount <* R.eof) () "" txt])
+ [Text.length txt] in
+ (==>) <$>
+ [ "0.00"
+ , "123"
+ , "-123"
+ , "12.3"
+ , "12.5"
+ , "12.3"
+ , "1,234.56"
+ , "123,456,789,01,2.3456789"
+ , "1234567.8_90_123_456_789"
+ , "1,2,3,4,5,6,7,89,012.3456789"
+ , "1234567.890_12_3_4_5_6_7_8_9"
+ , "1000000.000_00_0_0_0_0_0_0_0"
+ , "999"
+ , "1000"
+ , "10,00€"
+ , "10,00 €"
+ , "€10,00"
+ , "€ 10,00"
+ , "EUR 10,00"
+ , "10,00 EUR"
+ , "\"4 2\" 10,00"
+ ]
+ , testGroup "write_account" $
+ let (==>) txt =
+ testCase (Text.unpack txt) $
+ (@?=)
+ (let read (t::Text) =
+ rights [R.runParser
+ (Ledger.read_account <* R.eof)
+ () "" t] in
+ Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True } <$>
+ (read txt >>= \a ->
+ let Ledger.Posting_Typed ty ac = Ledger.read_posting_type a in
+ return $ Ledger.write_account ty ac)
+ )
+ [TL.fromStrict txt] in
+ (==>) <$>
+ [ "A"
+ , "(A:B:C)"
+ , "[A:B:C]"
+ ]
+ , testGroup "write_transaction" $
+ let (==>) (txt::Text) =
+ testCase (Text.unpack txt) .
+ (@?=) (
+ let write (txn, ctx) =
+ Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True } $
+ let jnl = Ledger.context_read_journal ctx in
+ let sty = Ledger.journal_amount_styles jnl in
+ Ledger.write_transaction sty txn in
+ either
+ (const []) {-(pure . TL.pack . show)-}
+ (pure . write) $
+ R.runParserWithError
+ (R.and_state (Ledger.read_transaction <* R.newline <* R.eof))
+ ( Ledger.context_read Ledger.charted Ledger.journal
+ ::Ledger.Context_Read Ledger.Transaction [Ledger.Transaction] )
+ "" txt) in
+ [ Text.unlines
+ [ "2000-01-01 some wording"
+ , " A:B:C $1"
+ , " a:b:c"
+ ] ==> [TL.unlines
+ [ "2000-01-01 some wording"
+ , " A:B:C $1"
+ , " a:b:c $-1"
+ ]]
+ , Text.unlines
+ [ "2000-01-01 some wording"
+ , " A:B:C $1"
+ , " a:b:c"
+ , " ; first comment"
+ , " ; second comment"
+ , " ; third comment"
+ ] ==> [TL.unlines
+ [ "2000-01-01 some wording"
+ , " A:B:C $1"
+ , " a:b:c $-1"
+ , " ; first comment"
+ , " ; second comment"
+ , " ; third comment"
+ ]]
+ , Text.unlines
+ [ "2000-01-01 some wording"
+ , " A:B:C $1"
+ , " AA:BB:CC $123"
+ ] ==> []
+ , testCase "empty" $
+ Ledger.write
+ Ledger.write_style
+ { Ledger.write_style_color = False
+ , Ledger.write_style_align = True }
+ (Ledger.write_transaction
+ Ledger.amount_styles
+ Ledger.transaction)
+ @?= "1970-01-01\n\n"
+ ]
+ ]
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
-import Test.HUnit hiding (test)
-import Test.Framework.Providers.HUnit (hUnitTestToTests)
-import Test.Framework.Runners.Console (defaultMain)
-
-import Control.Applicative (Applicative(..))
-import Control.Arrow (ArrowChoice(..))
-import Control.Monad (Monad(..))
-import Control.Monad.IO.Class (liftIO)
-import Data.Bool (Bool(..))
-import Data.Decimal (DecimalRaw(..))
-import qualified Data.Either
-import Data.Either (rights, either)
-import Data.Eq (Eq(..))
-import Data.Function (($), (.), id, const)
-import Data.Functor (Functor(..), (<$>))
-import Data.List ((++))
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..), maybe)
-import Data.Monoid (Monoid(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import qualified Data.Time.Calendar as Time
-import qualified Data.Time.LocalTime as Time
-import System.IO (IO)
-import qualified Text.Parsec as R hiding (char, space, spaces, string)
-import qualified Text.Parsec.Pos as R
-
-import qualified Hcompta.Chart as Chart
-import qualified Hcompta.Date as Date
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Tag as Tag
-import qualified Hcompta.Transaction as Transaction
-
-import qualified Hcompta.Format.Ledger as F
-import qualified Hcompta.Format.Ledger.Read as F
-import qualified Hcompta.Format.Ledger.Write as F
-
-deriving instance Eq F.Amount
-
-main :: IO ()
-main = defaultMain $ hUnitTestToTests test
-
-test :: Test
-test = TestList
- [ "Read" ~: TestList
- [ "read_date" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) .
- (~?=)
- (rights [R.runParser_with_Error
- (F.read_date id Nothing <* R.eof) () "" txt])
- in TestList $
- [ "2000-01-01" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc) ]
- , "2000/01/01" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc) ]
- , "2000-01-01_12:34" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 12 34 0))
- (Time.utc) ]
- , "2000-01-01_12:34:56" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 12 34 56))
- (Time.utc) ]
- , "2000-01-01_12:34_CET" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 12 34 0))
- (Time.TimeZone 60 True "CET") ]
- , "2000-01-01_12:34+01:30" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 12 34 0))
- (Time.TimeZone 90 False "+01:30") ]
- , "2000-01-01_12:34:56_CET" ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 12 34 56))
- (Time.TimeZone 60 True "CET") ]
- , "2001-02-29" ==> []
- ] ++
- let (==>) (txt::Text, def) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser_with_Error
- (F.read_date id (Just def) <* R.eof) () "" txt])
- in
- [ ("01-01", 2000) ==>
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)]
- ]
- , "read_account_section" ~:
- let (==>) (txt::Text) b =
- (~:) (Text.unpack txt) $
- (~?=)
- (rights [R.runParser (F.read_account_section <* R.eof) () "" txt])
- (if b then [txt] else [])
- in TestList
- [ "" ==> False
- , "A" ==> True
- , "AA" ==> True
- , " " ==> False
- , ":" ==> False
- , "A:" ==> False
- , ":A" ==> False
- , "A " ==> False
- , "A A" ==> True
- , "A " ==> False
- , "A\t" ==> False
- , "A \n" ==> False
- , "(A)A" ==> True
- , "( )A" ==> True
- , "(A) A" ==> True
- , "[ ] A" ==> True
- , "(A) " ==> False
- , "(A)" ==> True
- , "A(A)" ==> True
- , "[A]A" ==> True
- , "[A] A" ==> True
- , "[A] " ==> False
- , "[A]" ==> True
- , "\"A \"" ~:
- (rights
- [R.runParser
- (F.read_account_section)
- () "" ("A "::Text)])
- ~?=
- ["A"]
- ]
- , "read_account" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser
- (F.read_account <* R.eof) () "" txt])
- in TestList
- [ "" ==> []
- , "A" ==> ["A":|[]]
- , "A:" ==> []
- , ":A" ==> []
- , "A " ==> []
- , " A" ==> []
- , "A:B" ==> ["A":|["B"]]
- , "A:B:C" ==> ["A":|["B","C"]]
- , "Aa:Bbb:Cccc" ==> ["Aa":|["Bbb", "Cccc"]]
- , "A a : B b b : C c c c" ==> ["A a ":|[" B b b ", " C c c c"]]
- , "A: :C" ==> ["A":|[" ", "C"]]
- , "A::C" ==> []
- , "A:B:(C)" ==> ["A":|["B", "(C)"]]
- ]
- , "read_amount" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_amount <* R.eof) () "" txt])
- in TestList
- [ "" ==> []
- , "0" ==>
- [( mempty
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , "00" ==>
- [( mempty
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , "0." ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , ".0" ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 1 0 } )]
- , "0," ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , ",0" ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 1 0 } )]
- , "0_" ==> []
- , "_0" ==> []
- , "0.0" ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 1 0 } )]
- , "00.00" ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 2 0 } )]
- , "0,0" ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 1 0 } )]
- , "00,00" ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 2 0 } )]
- , "0_0" ==>
- [( mempty { F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [1] }
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , "00_00" ==>
- [( mempty { F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [2] }
- , F.amount { F.amount_quantity = Decimal 0 0 } )]
- , "0,000.00" ==>
- [( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [3] }
- , F.amount { F.amount_quantity = Decimal 2 0 } )]
- , "0.000,00" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '.' [3] }
- , F.amount { F.amount_quantity = Decimal 2 0 } )]
- , "1,000.00" ==>
- [( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [3] }
- , F.amount { F.amount_quantity = Decimal 2 100000 } )]
- , "1.000,00" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '.' [3] }
- , F.amount { F.amount_quantity = Decimal 2 100000 } )]
- , "1,000.00." ==> []
- , "1.000,00," ==> []
- , "1,000.00_" ==> []
- , "123" ==>
- [( mempty
- , F.amount { F.amount_quantity = Decimal 0 123 } )]
- , "1.2" ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 1 12 } )]
- , "1,2" ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 1 12 } )]
- , "12.34" ==>
- [( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 2 1234 } )]
- , "12,34" ==>
- [( mempty { F.amount_style_fractioning = Just ',' }
- , F.amount { F.amount_quantity = Decimal 2 1234 } )]
- , "1_2" ==>
- [( mempty { F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [1] }
- , F.amount { F.amount_quantity = Decimal 0 12 } )]
- , "1_23" ==>
- [( mempty { F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [2] }
- , F.amount { F.amount_quantity = Decimal 0 123 } )]
- , "1_23_456" ==>
- [( mempty { F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [3, 2] }
- , F.amount { F.amount_quantity = Decimal 0 123456 } )]
- , "1_23_456,7890_12345_678901" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [3, 2]
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [4, 5, 6] }
- , F.amount { F.amount_quantity = Decimal 15 123456789012345678901 } )]
- , "1_23_456.7890_12345_678901" ==>
- [( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [3, 2]
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [4, 5, 6] }
- , F.amount { F.amount_quantity = Decimal 15 123456789012345678901 } )]
- , "1,23,456.7890_12345_678901" ==>
- [( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [3, 2]
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [4, 5, 6] }
- , F.amount { F.amount_quantity = Decimal 15 123456789012345678901 } )]
- , "1.23.456,7890_12345_678901" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '.' [3, 2]
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [4, 5, 6] }
- , F.amount { F.amount_quantity = Decimal 15 123456789012345678901 } )]
- , "123456_78901_2345.678_90_1" ==>
- [( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '_' [4, 5, 6]
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [3, 2] }
- , F.amount { F.amount_quantity = Decimal 6 123456789012345678901 } )]
- , "$1" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "$" } )]
- , "1$" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Right
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "$" } )]
- , "$ 1" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just True }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "$" } )]
- , "1 $" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Right
- , F.amount_style_unit_spaced = Just True }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "$" } )]
- , "-$1" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 0 (-1)
- , F.amount_unit = "$" } )]
- , "\"4 2\"1" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "4 2" } )]
- , "1\"4 2\"" ==>
- [( mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Right
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 0 1
- , F.amount_unit = "4 2" } )]
- , "$1.000,00" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '.' [3]
- , F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 2 100000
- , F.amount_unit = "$" } )]
- , "1.000,00$" ==>
- [( mempty
- { F.amount_style_fractioning = Just ','
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping '.' [3]
- , F.amount_style_unit_side = Just F.Amount_Style_Side_Right
- , F.amount_style_unit_spaced = Just False }
- , F.amount
- { F.amount_quantity = Decimal 2 100000
- , F.amount_unit = "$" } )]
- ]
- , "read_posting_type" ~:
- let (==>) a (ty, ac) =
- let read (t::Text) = rights [R.runParser
- (F.read_account <* R.eof) () "" t] in
- (~:) (Text.unpack a) $
- (~?=)
- (F.read_posting_type <$> read a)
- (F.Posting_Typed ty <$> read (maybe a id ac))
- in TestList
- [ "A" ==> (F.Posting_Type_Regular, Nothing)
- , "(" ==> (F.Posting_Type_Regular, Nothing)
- , ")" ==> (F.Posting_Type_Regular, Nothing)
- , "()" ==> (F.Posting_Type_Regular, Nothing)
- , "( )" ==> (F.Posting_Type_Regular, Nothing)
- , "(A)" ==> (F.Posting_Type_Virtual, Just "A")
- , "(A:B:C)" ==> (F.Posting_Type_Virtual, Just "A:B:C")
- , "A:B:C" ==> (F.Posting_Type_Regular, Nothing)
- , "(A):B:C" ==> (F.Posting_Type_Regular, Nothing)
- , "A:(B):C" ==> (F.Posting_Type_Regular, Nothing)
- , "A:B:(C)" ==> (F.Posting_Type_Regular, Nothing)
- , "[" ==> (F.Posting_Type_Regular, Nothing)
- , "]" ==> (F.Posting_Type_Regular, Nothing)
- , "[]" ==> (F.Posting_Type_Regular, Nothing)
- , "[ ]" ==> (F.Posting_Type_Regular, Nothing)
- , "[A]" ==> (F.Posting_Type_Virtual_Balanced, Just "A")
- , "[A:B:C]" ==> (F.Posting_Type_Virtual_Balanced, Just "A:B:C")
- , "A:B:C" ==> (F.Posting_Type_Regular, Nothing)
- , "[A]:B:C" ==> (F.Posting_Type_Regular, Nothing)
- , "A:[B]:C" ==> (F.Posting_Type_Regular, Nothing)
- , "A:B:[C]" ==> (F.Posting_Type_Regular, Nothing)
- ]
- , "read_comment" ~:
- let (==>) (txt::Text, end) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_comment <* end) () "" txt])
- in TestList
- [ ("; some comment", R.eof) ==> [" some comment"]
- , ("; some comment \n", R.newline <* R.eof) ==> [ " some comment " ]
- , ("; some comment \r\n", R.string "\r\n" <* R.eof) ==> [ " some comment " ]
- ]
- , "read_comments" ~:
- let (==>) (txt::Text, end) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_comments <* end) () "" txt])
- in TestList
- [ ("; some comment\n ; some other comment", R.eof) ==> [ [" some comment", " some other comment"] ]
- , ("; some comment \n", R.string "\n" <* R.eof) ==> [ [" some comment "] ]
- ]
- , "read_tag_value" ~:
- let (==>) (txt::Text, end) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_tag_value <* end) () "" txt])
- in TestList
- [ (",", R.eof) ==> [","]
- , (",\n", R.char '\n' <* R.eof) ==> [","]
- , (",x", R.eof) ==> [",x"]
- , (",x:", R.string ",x:" <* R.eof) ==> [""]
- , ("v, v, n:", R.string ", n:" <* R.eof) ==> ["v, v"]
- ]
- , "read_tag" ~:
- let (==>) (txt::Text, end) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_tag <* end) () "" txt])
- in TestList
- [ ("Name:" , R.eof) ==> [("Name":|[], "")]
- , ("Name:Value" , R.eof) ==> [("Name":|[], "Value")]
- , ("Name:Value\n" , R.string "\n" <* R.eof) ==> [("Name":|[], "Value")]
- , ("Name:Val ue" , R.eof) ==> [("Name":|[], "Val ue")]
- , ("Name:," , R.eof) ==> [("Name":|[], ",")]
- , ("Name:Val,ue" , R.eof) ==> [("Name":|[], "Val,ue")]
- , ("Name:Val,ue:" , R.string ",ue:" <* R.eof) ==> [("Name":|[], "Val")]
- , ("Name:Val,ue :", R.eof) ==> [("Name":|[], "Val,ue :")]
- ]
- , "read_tags" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser (F.read_tags <* R.eof) () "" txt]) .
- pure . Map.fromList
- in TestList
- [ "Name:" ==> [ ("Name":|[], [""]) ]
- , "Name:," ==> [ ("Name":|[], [","]) ]
- , "Name:,Name:" ==> [ ("Name":|[], ["", ""]) ]
- , "Name:,Name2:" ==>
- [ ("Name":|[], [""])
- , ("Name2":|[], [""])
- ]
- , "Name: , Name2:" ==>
- [ ("Name":|[], [" "])
- , ("Name2":|[], [""])
- ]
- , "Name:,Name2:,Name3:" ==>
- [ ("Name":|[], [""])
- , ("Name2":|[], [""])
- , ("Name3":|[], [""])
- ]
- , "Name:Val ue,Name2:V a l u e,Name3:V al ue" ==>
- [ ("Name":|[], ["Val ue"])
- , ("Name2":|[], ["V a l u e"])
- , ("Name3":|[], ["V al ue"])
- ]
- ]
- , "read_posting" ~:
- let (==>) (txt::Text) =
- let read_context =
- ( F.read_context (const ()) F.journal
- ::F.Read_Context () ()) in
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser_with_Error
- (F.read_posting <* R.eof) read_context "" txt]) .
- fmap (\p -> F.Posting_Typed F.Posting_Type_Regular
- p { F.posting_sourcepos = R.newPos "" 1 1 })
- in TestList
- [ " A:B:C" ==> [F.posting ("A":|["B", "C"])]
- , "A:B:C" ==> []
- , " !A:B:C" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_status = True }]
- , " *A:B:C" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_status = True }]
- , " A:B:C $1" ==> [F.posting ("A":|["B", "C $1"])]
- , " A:B:C $1" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [("$", 1)] }]
- , " A:B:C $1 + 1€" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [("$", 1), ("€", 1)] }]
- , " A:B:C $1 + 1$" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [("$", 2)] }]
- , " A:B:C $1 + 1$ + 1$" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [("$", 3)] }]
- , " A:B:C ; some comment" ==> [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList []
- , F.posting_comments = [" some comment"] }]
- , " A:B:C ; some comment\n ; some other comment" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList []
- , F.posting_comments = [" some comment", " some other comment"] }]
- , " A:B:C $1 ; some comment" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [("$", 1)]
- , F.posting_comments = [" some comment"] }]
- , " A:B:C ; N:V" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" N:V"]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List [ ("N":|[], "V") ] }]
- , " A:B:C ; some comment N:V" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" some comment N:V"]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List [ ("N":|[], "V") ] }]
- , " A:B:C ; some comment N:V v, N2:V2 v2" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" some comment N:V v, N2:V2 v2"]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List
- [ ("N":|[], "V v")
- , ("N2":|[], "V2 v2") ] }]
- , " A:B:C ; N:V\n ; N:V2" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" N:V", " N:V2"]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List
- [ ("N":|[], "V")
- , ("N":|[], "V2")
- ] }]
- , " A:B:C ; N:V\n ; N2:V" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" N:V", " N2:V"]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List
- [ ("N":|[], "V")
- , ("N2":|[], "V")
- ] }]
- , " A:B:C ; date:2001-01-01" ==>
- [(F.posting ("A":|["B", "C"]))
- { F.posting_comments = [" date:2001-01-01"]
- , F.posting_dates =
- [ Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2001 01 01)
- (Time.TimeOfDay 0 0 0))
- Time.utc
- ]
- , F.posting_tags = Posting.Posting_Tags $
- Tag.from_List
- [ ("date":|[], "2001-01-01") ] }]
- , " (A:B:C) = Right (A:B:C)" ~:
- (rights [R.runParser_with_Error
- (F.read_posting <* R.eof)
- ( F.read_context (const ()) F.journal
- ::F.Read_Context () ())
- "" (" (A:B:C)"::Text)]) ~?=
- [F.Posting_Typed
- F.Posting_Type_Virtual
- (F.posting ("A":|["B", "C"]))]
- , " [A:B:C] = Right [A:B:C]" ~:
- (rights [R.runParser_with_Error
- (F.read_posting <* R.eof)
- ( F.read_context (const ()) F.journal
- ::F.Read_Context () ())
- "" (" [A:B:C]"::Text)]) ~?=
- [F.Posting_Typed
- F.Posting_Type_Virtual_Balanced
- (F.posting ("A":|["B", "C"]))]
- ]
- , "read_transaction" ~:
- let (==>) (txt::Text) =
- let read_context =
- ( F.read_context (const ()) F.journal
- ::F.Read_Context () ()) in
- (~:) (Text.unpack txt) .
- (~?=) (rights [R.runParser_with_Error
- (F.read_transaction <* R.eof) read_context "" txt]) .
- fmap (\t -> t { F.transaction_sourcepos = R.newPos "" 1 1 })
- in TestList
- [ "2000-01-01 some wording\n A:B:C $1\n a:b:c" ==>
- [F.transaction
- { F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="some wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 2 1 }
- , (F.posting ("a":|["b", "c"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 3 1 }
- ]
- }]
- , "2000-01-01 some wording\n A:B:C $1\n a:b:c\n" ==> []
- , "2000-01-01 some wording ; some comment\n ; some other;comment\n ; some Tag:\n ; some last comment\n A:B:C $1\n a:b:c" ==>
- [F.transaction
- { F.transaction_comments_after =
- [ " some comment"
- , " some other;comment"
- , " some Tag:"
- , " some last comment"
- ]
- , F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="some wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 5 1 }
- , (F.posting ("a":|["b", "c"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 6 1 } ]
- , F.transaction_tags = Transaction.Transaction_Tags $
- Tag.from_List [ ("Tag":|[], "") ] }]
- ]
- , "read_journal" ~: TestList
- [ "2000-01-01 1° wording\\n A:B:C $1\\n a:b:c\\n2000-01-02 2° wording\\n A:B:C $1\\n x:y:z" ~: TestCase $ do
- jnl <- liftIO $
- R.runParserT_with_Error
- (F.read_journal "" {-<* R.eof-})
- ( F.read_context id F.journal
- ::F.Read_Context (F.Charted F.Transaction)
- ([F.Charted F.Transaction]))
- "" ("2000-01-01 1° wording\n A:B:C $1\n a:b:c\n2000-01-02 2° wording\n A:B:C $1\n x:y:z"::Text)
- ((\j -> j{F.journal_last_read_time=Date.nil}) <$>
- Data.Either.rights [jnl])
- @?=
- [F.journal
- { F.journal_content =
- fmap (Chart.Charted mempty) $
- [ F.transaction
- { F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 02)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="2° wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 5 1
- }
- , (F.posting ("x":|["y", "z"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 6 1
- }
- ]
- , F.transaction_sourcepos = R.newPos "" 4 1
- }
- , F.transaction
- { F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="1° wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 2 1
- }
- , (F.posting ("a":|["b", "c"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 3 1
- }
- ]
- , F.transaction_sourcepos = R.newPos "" 1 1
- }
- ]
- , F.journal_files = [""]
- , F.journal_amount_styles = F.Amount_Styles $ Map.fromList
- [ ( F.Unit "$"
- , mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- )
- ]
- }
- ]
- ]
- , "read_journal" ~: TestList
- [ let (==>) (txt::Text) e =
- (~:) (Text.unpack txt) $
- TestCase $ do
- jnl <-
- liftIO $
- right (\j -> j{F.journal_last_read_time=Date.nil}) <$>
- R.runParserT_with_Error
- (F.read_journal "" {-<* R.eof-})
- ( F.read_context id F.journal
- ::F.Read_Context (F.Charted F.Transaction)
- ([F.Charted F.Transaction]))
- "" (txt::Text)
- (@?=) (rights [jnl]) e
- in TestList
- [ Text.unlines
- [ "2000-01-01 1° wording"
- , " A:B:C $1"
- , " a:b:c"
- , "2000-01-02 2° wording"
- , " A:B:C $1"
- , " x:y:z"
- ] ==>
- [ F.journal
- { F.journal_content =
- fmap (Chart.Charted mempty) $
- [ F.transaction
- { F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 02)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="2° wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 5 1
- }
- , (F.posting ("x":|["y", "z"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 6 1
- }
- ]
- , F.transaction_sourcepos = R.newPos "" 4 1
- }
- , F.transaction
- { F.transaction_dates=
- ( Time.zonedTimeToUTC $
- Time.ZonedTime
- (Time.LocalTime
- (Time.fromGregorian 2000 01 01)
- (Time.TimeOfDay 0 0 0))
- (Time.utc)
- , [] )
- , F.transaction_wording="1° wording"
- , F.transaction_postings = F.postings_by_account
- [ (F.posting ("A":|["B", "C"]))
- { F.posting_amounts = Map.fromList [ ("$", 1) ]
- , F.posting_sourcepos = R.newPos "" 2 1
- }
- , (F.posting ("a":|["b", "c"]))
- { F.posting_amounts = Map.fromList [ ("$", -1) ]
- , F.posting_sourcepos = R.newPos "" 3 1
- }
- ]
- , F.transaction_sourcepos = R.newPos "" 1 1
- }
- ]
- , F.journal_files = [""]
- , F.journal_amount_styles = F.Amount_Styles $ Map.fromList
- [ ( F.Unit "$"
- , mempty
- { F.amount_style_unit_side = Just F.Amount_Style_Side_Left
- , F.amount_style_unit_spaced = Just False }
- )
- ]
- }
- ]
- ]
- ]
- ]
- , "Write" ~: TestList
- [ "write_date" ~:
- let (==>) (txt::Text) e =
- (~:) (Text.unpack txt) $
- (~?=)
- (F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } .
- F.write_date <$>
- rights [R.runParser_with_Error
- (F.read_date id Nothing <* R.eof) () "" txt])
- [e]
- in TestList
- [ "" ~:
- ((F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } $
- F.write_date Date.nil)
- ~?= "1970-01-01")
- , "2000-01-01" ==> "2000-01-01"
- , "2000-01-01_12:34:51_CET" ==> "2000-01-01_11:34:51"
- , "2000-01-01_12:34:51+01:10" ==> "2000-01-01_11:24:51"
- , "2000-01-01_12:34:51-01:10" ==> "2000-01-01_13:44:51"
- , "2000-01-01_01:02:03" ==> "2000-01-01_01:02:03"
- , "2000-01-01_01:02" ==> "2000-01-01_01:02"
- , "2000-01-01_01:00" ==> "2000-01-01_01:00"
- ]
- , "write_amount" ~:
- let (<==) (txt::Text) e =
- (~:) (Text.unpack txt) $
- (~?=)
- (F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } $
- F.write_amount e)
- (TL.fromStrict txt)
- in TestList
- [ "0" <==
- ( mempty
- , F.amount )
- , "0.00" <==
- ( mempty
- , F.amount { F.amount_quantity = Decimal 2 0 } )
- , "123" <==
- ( mempty
- , F.amount { F.amount_quantity = Decimal 0 123 } )
- , "-123" <==
- ( mempty
- , F.amount { F.amount_quantity = Decimal 0 (- 123) } )
- , "12.3" <==
- ( mempty { F.amount_style_fractioning = Just '.' }
- , F.amount { F.amount_quantity = Decimal 1 123 } )
- , "1,234.56" <==
- ( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [3]
- }
- , F.amount { F.amount_quantity = Decimal 2 123456 })
- , "123,456,789,01,2.3456789" <==
- ( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [1, 2, 3]
- }
- , F.amount { F.amount_quantity = Decimal 7 1234567890123456789 } )
- , "1234567.8_90_123_456_789" <==
- ( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [1, 2, 3]
- }
- , F.amount { F.amount_quantity = Decimal 12 1234567890123456789 })
- , "1,2,3,4,5,6,7,89,012.3456789" <==
- ( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_integral = Just $ F.Amount_Style_Grouping ',' [3, 2, 1]
- }
- , F.amount { F.amount_quantity = Decimal 7 1234567890123456789 })
- , "1234567.890_12_3_4_5_6_7_8_9" <==
- ( mempty
- { F.amount_style_fractioning = Just '.'
- , F.amount_style_grouping_fractional = Just $ F.Amount_Style_Grouping '_' [3, 2, 1]
- }
- , F.amount { F.amount_quantity = Decimal 12 1234567890123456789 })
- ]
- , "write_amount_length" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) $
- (~?=)
- (F.write_amount_length <$>
- rights [R.runParser (F.read_amount <* R.eof) () "" txt])
- [Text.length txt]
- in TestList $ (==>) <$>
- [ "0.00"
- , "123"
- , "-123"
- , "12.3"
- , "12.5"
- , "12.3"
- , "1,234.56"
- , "123,456,789,01,2.3456789"
- , "1234567.8_90_123_456_789"
- , "1,2,3,4,5,6,7,89,012.3456789"
- , "1234567.890_12_3_4_5_6_7_8_9"
- , "1000000.000_00_0_0_0_0_0_0_0"
- , "999"
- , "1000"
- , "10,00€"
- , "10,00 €"
- , "€10,00"
- , "€ 10,00"
- , "EUR 10,00"
- , "10,00 EUR"
- , "\"4 2\" 10,00"
- ]
- , "write_account" ~:
- let (==>) txt =
- (~:) (Text.unpack txt) $
- (~?=)
- (let read (t::Text) =
- rights [R.runParser
- (F.read_account <* R.eof)
- () "" t] in
- F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } <$>
- (read txt >>= \a ->
- let F.Posting_Typed ty ac = F.read_posting_type a in
- return $ F.write_account ty ac)
- )
- [TL.fromStrict txt]
- in TestList $ (==>) <$>
- [ "A"
- , "(A:B:C)"
- , "[A:B:C]"
- ]
- , "write_transaction" ~:
- let (==>) (txt::Text) =
- (~:) (Text.unpack txt) .
- (~?=) (
- let write (txn, ctx) =
- F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } $
- let jnl = F.read_context_journal ctx in
- let sty = F.journal_amount_styles jnl in
- F.write_transaction sty txn in
- either
- (const []) {-(pure . TL.pack . show)-}
- (pure . write) $
- R.runParser_with_Error
- (R.and_state (F.read_transaction <* R.newline <* R.eof))
- ( F.read_context Chart.charted F.journal
- ::F.Read_Context F.Transaction [F.Transaction] )
- "" txt)
- in TestList $
- [ Text.unlines
- [ "2000-01-01 some wording"
- , " A:B:C $1"
- , " a:b:c"
- ] ==> [TL.unlines
- [ "2000-01-01 some wording"
- , " A:B:C $1"
- , " a:b:c $-1"
- ]]
- , Text.unlines
- [ "2000-01-01 some wording"
- , " A:B:C $1"
- , " a:b:c"
- , " ; first comment"
- , " ; second comment"
- , " ; third comment"
- ] ==> [TL.unlines
- [ "2000-01-01 some wording"
- , " A:B:C $1"
- , " a:b:c $-1"
- , " ; first comment"
- , " ; second comment"
- , " ; third comment"
- ]]
- , Text.unlines
- [ "2000-01-01 some wording"
- , " A:B:C $1"
- , " AA:BB:CC $123"
- ] ==> []
- ] ++
- [ "nil" ~:
- ((F.write
- F.write_style
- { F.write_style_color = False
- , F.write_style_align = True } $
- F.write_transaction
- F.amount_styles
- F.transaction)
- ~?= "1970-01-01\n\n")
- ]
- ]
- ]
-haddock
- html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html
+executable-dynamic: False
author: Julien Moutinho <julm+hcompta@autogeree.net>
-bug-reports: http://doc.autogeree.net/hcompta/bugs
+-- bug-reports: http://bug.autogeree.net/hcompta
build-type: Simple
cabal-version: >= 1.8
category: Finance
-- data-dir: data
-- data-files:
description: Ledger support for Hcompta.
-extra-source-files: Test.hs
+extra-source-files:
extra-tmp-files:
-homepage: http://doc.autogeree.net/coop/hcompta
-license: GPL
+-- homepage: http://pad.autogeree.net/hcompta
+license: GPL-3
license-file: COPYING
maintainer: Julien Moutinho <julm+hcompta@autogeree.net>
name: hcompta-ledger
stability: experimental
synopsis: hcompta
-tested-with: GHC==7.8.4
-version: 0.0.0
+tested-with: GHC==7.10.3
+version: 1.201608
-source-repository head
+Source-Repository head
location: git://git.autogeree.net/hcompta
type: git
Flag dev
Default: False
Description: Turn on development settings.
+ Manual: True
Flag dump
Default: False
Flag prof
Default: False
Description: Turn on profiling settings.
+ Manual: True
+
+Flag threaded
+ Default: False
+ Description: Enable threads.
+ Manual: True
Library
extensions: NoImplicitPrelude
if flag(dev)
cpp-options: -DDEVELOPMENT
ghc-options:
- -- -ddump-splices
- -- -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures
- -- -fno-warn-type-defaults -fno-warn-orphans
- else
- ghc-options: -O2
if flag(prof)
cpp-options: -DPROFILING
- ghc-options: -O2 -fprof-auto
+ ghc-options: -fprof-auto
if flag(dump)
ghc-options: -ddump-simpl -ddump-stg -ddump-to-file
-- default-language: Haskell2010
exposed-modules:
- Hcompta.Format.Ledger
- Hcompta.Format.Ledger.Account
- Hcompta.Format.Ledger.Amount
- Hcompta.Format.Ledger.Chart
- Hcompta.Format.Ledger.Journal
- Hcompta.Format.Ledger.Posting
- Hcompta.Format.Ledger.Read
- Hcompta.Format.Ledger.Transaction
- Hcompta.Format.Ledger.Write
+ Hcompta.Ledger
+ Hcompta.Ledger.Account
+ Hcompta.Ledger.Amount
+ Hcompta.Ledger.Chart
+ Hcompta.Ledger.Journal
+ Hcompta.Ledger.Lib.FilePath
+ Hcompta.Ledger.Lib.Parsec
+ Hcompta.Ledger.Posting
+ Hcompta.Ledger.Read
+ Hcompta.Ledger.Transaction
+ Hcompta.Ledger.Write
build-depends:
base >= 4.6 && < 5
, ansi-terminal >= 0.4 && < 0.7
, array
, containers >= 0.5 && < 0.6
-- NOTE: needed for Data.Map.Strict
- -- , collections-api
- -- , collections-base-instances
, Decimal
, deepseq
, directory
, filepath
, fingertree
, hcompta-lib
- -- , HUnit
, integer-gmp
-- , lens
-- , mmorph
-- , mtl >= 2.0
, parsec >= 3.1.2 && < 4
-- NOTE: needed for Text.Parsec.Text
+ , parsec-error-custom
, regex-base
, regex-tdfa
+ , regex-tdfa-replace
, regex-tdfa-text
-- , safe >= 0.2
+ , safe-exceptions
, semigroups
, strict
- , test-framework
- , test-framework-hunit
, text
, time
- -- , trace
, transformers >= 0.4 && < 0.5
-- NOTE: needed for Control.Monad.Trans.Except
+ , treemap
+ , walderleijen-ansi-text
-test-suite Test
- extensions: NoImplicitPrelude
+Test-Suite hcompta-ledger-test
type: exitcode-stdio-1.0
- main-is: Main.hs
- hs-source-dirs: Test
- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures
- ghc-options: -fno-warn-type-defaults -fno-warn-orphans -fno-warn-tabs
-- default-language: Haskell2010
+ extensions: NoImplicitPrelude
+ ghc-options: -Wall -fno-warn-tabs
+ -main-is Test
+ hs-source-dirs: Hcompta/Ledger
+ main-is: Test.hs
+ other-modules:
+ Read.Test
+ -- Write.Test
+ if flag(threaded)
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ if flag(dev)
+ cpp-options: -DDEVELOPMENT
+ ghc-options:
+ if flag(prof)
+ cpp-options: -DPROFILING
+ ghc-options: -fprof-auto
build-depends:
- hcompta-ledger
- , hcompta-lib
- , base >= 4.6 && < 5
+ base >= 4.6 && < 5
, containers >= 0.5 && < 0.6
, Decimal
- , HUnit
+ , hcompta-lib
+ , hcompta-ledger
, parsec >= 3.1.2 && < 4
- -- , safe
+ -- NOTE: needed for Text.Parsec.Text
+ , parsec-error-custom
, semigroups
, strict
- , test-framework
- , test-framework-hunit
+ , tasty >= 0.11
+ , tasty-hunit
, text
, time
- , transformers
+ , transformers >= 0.4 && < 0.5
+ , treemap
+ , walderleijen-ansi-text
--- /dev/null
+#!/bin/sh -x
+cabal test hcompta-ledger-test --test-option=--color --test-option=always --show-details always "$@"
sourcephile / git / comptalang.git / commitdiff