module Penny.Lincoln.Ents
(
Ent
, entry
, meta
, inferred
, Ents
, unEnts
, tupleEnts
, mapEnts
, traverseEnts
, ents
, rEnts
, headEnt
, tailEnts
, Posting(..)
, Transaction(..)
, transactionToPostings
, views
, unrollSnd
) where
import Control.Applicative
import Control.Arrow (second)
import qualified Penny.Lincoln.Bits as B
import qualified Penny.Lincoln.Balance as Bal
import Control.Monad (guard)
import qualified Penny.Lincoln.Equivalent as Ev
import Penny.Lincoln.Equivalent ((==~))
import Data.Monoid (mconcat, (<>))
import Data.List (foldl', unfoldr, sortBy)
import Data.Maybe (catMaybes)
import qualified Data.Traversable as Tr
import qualified Data.Foldable as Fdbl
data Ent m = Ent
{ entry :: Either (B.Entry B.QtyRep) (B.Entry B.Qty)
, meta :: m
, inferred :: Bool
} deriving (Eq, Ord, Show)
instance Ev.Equivalent m => Ev.Equivalent (Ent m) where
equivalent (Ent e1 m1 _) (Ent e2 m2 _) = e1 ==~ e2 && m1 ==~ m2
compareEv (Ent e1 m1 _) (Ent e2 m2 _) =
Ev.compareEv e1 e2 <> Ev.compareEv m1 m2
instance Functor Ent where
fmap f (Ent e m i) = Ent e (f m) i
newtype Ents m = Ents { unEnts :: [Ent m] }
deriving (Eq, Ord, Show, Functor)
instance Ev.Equivalent m => Ev.Equivalent (Ents m) where
equivalent (Ents e1) (Ents e2) =
let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2)
in and $ (length e1 == length e2)
: zipWith Ev.equivalent e1' e2'
compareEv (Ents e1) (Ents e2) =
let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2)
in mconcat $ compare (length e1) (length e2)
: zipWith Ev.compareEv e1' e2'
instance Fdbl.Foldable Ents where
foldr f z (Ents ls) = case ls of
[] -> z
x:xs -> f (meta x) (Fdbl.foldr f z (map meta xs))
instance Tr.Traversable Ents where
sequenceA = fmap Ents . Tr.sequenceA . map seqEnt . unEnts
mapEnts :: (Ent a -> b) -> Ents a -> Ents b
mapEnts f = Ents . map f' . unEnts where
f' e = e { meta = f e }
traverseEnts :: Applicative f => (Ent a -> f b) -> Ents a -> f (Ents b)
traverseEnts f = fmap Ents . Tr.traverse f' . unEnts where
f' en@(Ent e _ i) = Ent <$> pure e <*> f en <*> pure i
seqEnt :: Applicative f => Ent (f a) -> f (Ent a)
seqEnt (Ent e m i) = Ent <$> pure e <*> m <*> pure i
tupleEnts :: Ents m -> (Ent m, Ent m, [Ent m])
tupleEnts (Ents ls) = case ls of
t1:t2:ts -> (t1, t2, ts)
_ -> error "tupleEnts: ents does not have two ents"
views :: Ents m -> [Ents m]
views = map Ents . orderedPermute . unEnts
unrollSnd :: (a, [b]) -> [(a, b)]
unrollSnd = unfoldr f where
f (_, []) = Nothing
f (a, b:bs) = Just ((a, b), (a, bs))
transactionToPostings :: Transaction -> [Posting]
transactionToPostings =
map Posting . unrollSnd . second views . unTransaction
headEnt :: Ents m -> Ent m
headEnt (Ents ls) = case ls of
[] -> error "ents: empty view"
x:_ -> x
tailEnts :: Ents m -> (Ent m, [Ent m])
tailEnts (Ents ls) = case ls of
[] -> error "ents: tailEnts: empty view"
_:xs -> case xs of
[] -> error "ents: tailEnts: only one sibling"
s2:ss -> (s2, ss)
newtype Transaction = Transaction
{ unTransaction :: ( B.TopLineData, Ents B.PostingData ) }
deriving (Eq, Show)
newtype Posting = Posting
{ unPosting :: ( B.TopLineData, Ents B.PostingData ) }
deriving (Eq, Show)
orderedPermute :: [a] -> [[a]]
orderedPermute ls = take (length ls) (iterate toTheBack ls)
where
toTheBack [] = []
toTheBack (a:as) = as ++ [a]
ents
:: [(Maybe (Either (B.Entry B.QtyRep) (B.Entry B.Qty)), m)]
-> Maybe (Ents m)
ents ls = do
guard . not . null $ ls
let nNoEntries = length . filter (== Nothing) . map fst $ ls
case Bal.entriesToBalanced
. map (either (fmap B.toQty) id)
. catMaybes
. map fst
$ ls of
Bal.NotInferable -> Nothing
Bal.Inferable e -> do
guard $ nNoEntries == 1
let makeEnt (mayEn, mt) = case mayEn of
Nothing -> Ent (Right e) mt True
Just en -> Ent en mt False
return . Ents $ map makeEnt ls
Bal.Balanced ->
let makeEnt (mayEn, mt) = case mayEn of
Nothing -> Nothing
Just en -> Just $ Ent en mt False
in fmap Ents $ mapM makeEnt ls
rEnts
:: B.Commodity
-> B.DrCr
-> (Either B.QtyRep B.Qty, m)
-> [(Either B.QtyRep B.Qty, m)]
-> m
-> Ents m
rEnts com dc (q1, m1) nonInfs lastMeta =
let tot = foldl' B.add (either B.toQty id q1)
. map (either B.toQty id . fst) $ nonInfs
p1 = makePstg (q1, m1)
ps = map makePstg nonInfs
makeEntry = either (\q -> Left (B.Entry dc (B.Amount q com)))
(\q -> Right (B.Entry dc (B.Amount q com)))
makePstg (q, m) = Ent (makeEntry q) m False
lastPstg = Ent (Right (B.Entry (B.opposite dc)
(B.Amount tot com))) lastMeta True
in Ents $ p1:ps ++ [lastPstg]