import System.Environment as Env (getProgName)
import System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO
-import Text.Show.Pretty (ppShow)
+import Text.Show.Pretty (ppShow) -- TODO: may be not necessary
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as Context
(flip mapM_) kos $ \(_path, ko) ->
Write.fatal context $ ko
([], journals) -> do
- CLI.Ledger.equilibre context journals
let balance =
Data.List.foldl
(\b j -> Balance.journal_with_virtual
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import Data.Map.Strict (Map)
+import Data.Foldable
import Data.Typeable ()
import Data.Maybe (fromMaybe)
import qualified GHC.Num
import qualified Hcompta.Model as Model ()
import qualified Hcompta.Model.Account as Account
+import qualified Hcompta.Lib.Foldable as Lib.Foldable
import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
import Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as Amount
Data.Map.empty
(by_unit balance)
+
+-- | Return either:
+--
+-- * 'Left': the 'Posting.By_Account's (lazy list) that cannot be inferred
+-- * 'Right': the given 'Posting.By_Account's with inferred 'Amount's inserted.
+infer_equilibre
+ :: Posting.By_Account
+ -> Either [Unit_Sum]
+ Posting.By_Account
+infer_equilibre ps = do
+ let bal = postings ps nil
+ let Equilibre equ = equilibre bal
+ (\(l, r) -> case l of
+ _:_ -> Left l
+ _ -> Right r) $ do
+ Lib.Foldable.accumLeftsAndFoldrRights
+ (\p -> Data.Map.insertWith
+ (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . Posting.amounts))
+ (Posting.account p) [p])
+ ps $ do
+ Data.Foldable.foldr
+ (\unit_sum@(Unit_Sum{ amount=amt, accounts }) acc ->
+ case Data.Map.size accounts of
+ 0 -> acc
+ 1 -> (Right $ (Posting.nil $ fst $ Data.Map.elemAt 0 accounts)
+ { Posting.amounts = Amount.from_List [negate amt] }
+ ):acc
+ _ -> Left [unit_sum]:acc
+ )
+ []
+ equ
+
-- ** Tests
-- | Return 'True' if and only if the given 'Equilibre' satisfies:
import qualified Data.Text as Text
import qualified System.FilePath.Posix as Path
+import qualified Hcompta.Calc.Balance as Calc.Balance
import qualified Hcompta.Model.Account as Account
import Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as Amount
(tags_of_comments comments_before)
(tags_of_comments comments_after)
R.new_line
- postings_ <- R.many1_separated posting R.new_line
- let (postings, postings__) =
- (Posting.from_List . Data.List.map fst) *** id $
- Data.List.partition
- ((Posting.Type_Regular ==) . snd)
- postings_
- let (virtual_postings, balanced_virtual_postings) =
+ (postings_unchecked, postings_not_regular) <-
+ ((Posting.from_List . Data.List.map fst) *** id) .
+ Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
+ R.many1_separated posting R.new_line
+ let (virtual_postings, balanced_virtual_postings_unchecked) =
join (***) (Posting.from_List . Data.List.map fst) $
- Data.List.partition
- ((Posting.Type_Virtual ==) . snd)
- postings__
+ Data.List.partition ((Posting.Type_Virtual ==) . snd)
+ postings_not_regular
+ postings <-
+ case Calc.Balance.infer_equilibre postings_unchecked of
+ Left _l -> fail $ "transaction not-equilibrated"
+ Right ps -> return ps
+ balanced_virtual_postings <-
+ case Calc.Balance.infer_equilibre balanced_virtual_postings_unchecked of
+ Left _l -> fail $ "virtual transaction not-equilibrated"
+ Right ps -> return ps
return $
Transaction.Transaction
{ Transaction.code=code_
module Hcompta.Lib.Foldable where
+import Data.Monoid
import Data.Maybe (listToMaybe, maybeToList)
-import Data.Foldable (Foldable, concatMap)
+import Data.Foldable (Foldable, foldMap, foldr)
-- | Return the first non-'Nothing' returned by the given function
-- applied on the elements of a 'Foldable'.
find :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
-find f = listToMaybe . Data.Foldable.concatMap (maybeToList . f)
+find f = listToMaybe . Data.Foldable.foldMap (maybeToList . f)
+
+-- | Like 'Data.Either.partitionEithers' but generalized
+-- to work on a 'Foldable' containing 'Monoid's.
+--
+-- NOTE: any lazyness on resulting 'Monoid's is preserved.
+partitionEithers
+ :: (Foldable t, Monoid r, Monoid l)
+ => t (Either l r) -> (l, r)
+partitionEithers m =
+ Data.Foldable.foldr (either left right) (mempty, mempty) m
+ where
+ left a ~(l, r) = (a`mappend`l, r)
+ right a ~(l, r) = (l, a`mappend`r)
+
+-- | Return a tuple of accumulated 'Left's and folded 'Right's
+-- in the given 'Foldable'.
+--
+-- NOTE: any lazyness on resulting 'Left's’ 'Monoid' is preserved.
+accumLeftsAndFoldrRights
+ :: (Foldable t, Monoid l)
+ => (r -> ra -> ra) -> ra -> t (Either l r) -> (l, ra)
+accumLeftsAndFoldrRights f rempty m =
+ Data.Foldable.foldr (either left right) (mempty, rempty) m
+ where
+ left a ~(l, r) = (a`mappend`l, r)
+ right a ~(l, r) = (l, f a r)
unions :: Foldable t => t Journal -> Journal
unions =
- Data.Foldable.foldl
+ Data.Foldable.foldl'
Hcompta.Model.Journal.union
Hcompta.Model.Journal.nil
=> m [Posting]
-> [Amount.Unit]
units =
- Data.Foldable.foldl
+ Data.Foldable.foldl'
(\acc ->
Data.List.union acc .
Data.List.concatMap
test_Hcompta :: Test
test_Hcompta =
TestList
- [ "Model" ~: TestList
+ [ "Lib" ~: TestList
+ [ "TreeMap" ~: TestList
+ [ "insert" ~: TestList
+ [ "[] 0" ~:
+ (Lib.TreeMap.insert const ((0::Int):|[]) () Lib.TreeMap.empty)
+ ~?=
+ (Lib.TreeMap.TreeMap $
+ Data.Map.fromList
+ [ ((0::Int), Lib.TreeMap.leaf ())
+ ])
+ , "[] 0/1" ~:
+ (Lib.TreeMap.insert const ((0::Int):|1:[]) () Lib.TreeMap.empty)
+ ~?=
+ (Lib.TreeMap.TreeMap $
+ Data.Map.fromList
+ [ ((0::Int), Lib.TreeMap.Node
+ { Lib.TreeMap.node_value = Nothing
+ , Lib.TreeMap.node_size = 1
+ , Lib.TreeMap.node_descendants =
+ Lib.TreeMap.singleton ((1::Int):|[]) ()
+ })
+ ])
+ ]
+ , "union" ~: TestList
+ [
+ ]
+ , "map_by_depth_first" ~: TestList
+ [
+ ]
+ , "flatten" ~: TestList
+ [ "[0, 0/1, 0/1/2]" ~:
+ (Lib.TreeMap.flatten id $
+ Lib.TreeMap.from_List const
+ [ ((0:|[]), ())
+ , ((0:|1:[]), ())
+ , ((0:|1:2:[]), ())
+ ]
+ )
+ ~?=
+ (Data.Map.fromList
+ [ ((0:|[]), ())
+ , ((0:|1:[]), ())
+ , ((0:|1:2:[]), ())
+ ])
+ , "[1, 1/2, 1/22, 1/2/3, 1/2/33, 11, 11/2, 11/2/3, 11/2/33]" ~:
+ (Lib.TreeMap.flatten id $
+ Lib.TreeMap.from_List const
+ [ ((1:|[]), ())
+ , ((1:|2:[]), ())
+ , ((1:|22:[]), ())
+ , ((1:|2:3:[]), ())
+ , ((1:|2:33:[]), ())
+ , ((11:|[]), ())
+ , ((11:|2:[]), ())
+ , ((11:|2:3:[]), ())
+ , ((11:|2:33:[]), ())
+ ]
+ )
+ ~?=
+ (Data.Map.fromList
+ [ ((1:|[]), ())
+ , ((1:|2:[]), ())
+ , ((1:|22:[]), ())
+ , ((1:|2:3:[]), ())
+ , ((1:|2:33:[]), ())
+ , ((11:|[]), ())
+ , ((11:|2:[]), ())
+ , ((11:|2:3:[]), ())
+ , ((11:|2:33:[]), ())
+ ])
+ ]
+ ]
+ ]
+ , "Model" ~: TestList
[ "Account" ~: TestList
[ "foldr" ~: TestList
[ "[A]" ~:
})
])
]
+ , "equilibre" ~: TestList
+ [ "{A+$1, $1}" ~:
+ (Calc.Balance.equilibre $
+ Calc.Balance.Balance
+ { Calc.Balance.by_account =
+ Lib.TreeMap.from_List const
+ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
+ , ("B":|[], Amount.from_List [])
+ ]
+ , Calc.Balance.by_unit =
+ Data.Map.fromList $
+ Data.List.map Calc.Balance.assoc_unit_sum $
+ [ Calc.Balance.Unit_Sum
+ { Calc.Balance.amount = Amount.usd $ 1
+ , Calc.Balance.accounts = Data.Map.fromList $ Data.List.map (,())
+ ["A":|[]]
+ }
+ ]
+ })
+ ~?=
+ (Calc.Balance.Equilibre $
+ Data.Map.fromList $
+ Data.List.map Calc.Balance.assoc_unit_sum $
+ [ Calc.Balance.Unit_Sum
+ { Calc.Balance.amount = Amount.usd $ 1
+ , Calc.Balance.accounts = Data.Map.fromList $ Data.List.map (,())
+ ["B":|[]]
+ }
+ ])
+ ]
, "is_equilibrable" ~: TestList
[ "nil" ~: TestCase $
(@=?) True $
]
}
]
+ , "infer_equilibre" ~: TestList
+ [ "{A+$1 B}" ~:
+ (Calc.Balance.infer_equilibre $
+ Posting.from_List
+ [ (Posting.nil ("A":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ 1 ] }
+ , (Posting.nil ("B":|[]))
+ { Posting.amounts=Amount.from_List [] }
+ ])
+ ~?=
+ (Right $
+ Posting.from_List
+ [ (Posting.nil ("A":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ 1 ] }
+ , (Posting.nil ("B":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ -1 ] }
+ ])
+ , "{A+$1 B-1€}" ~:
+ (Calc.Balance.infer_equilibre $
+ Posting.from_List
+ [ (Posting.nil ("A":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ 1 ] }
+ , (Posting.nil ("B":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.eur $ -1 ] }
+ ])
+ ~?=
+ (Right $
+ Posting.from_List
+ [ (Posting.nil ("A":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.eur $ 1 ] }
+ , (Posting.nil ("A":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ 1] }
+ , (Posting.nil ("B":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.usd $ -1 ] }
+ , (Posting.nil ("B":|[]))
+ { Posting.amounts=Amount.from_List [ Amount.eur $ -1 ] }
+ ])
+ ]
]
]
, "Format" ~: TestList
sourcephile / git / comptalang.git / commitdiff