module Penny.Lincoln.Ents
(
Inferred(..)
, Ent
, entry
, inferred
, meta
, Ents
, unEnts
, tupleEnts
, mapEnts
, traverseEnts
, ents
, rEnts
, headEnt
, tailEnts
, Posting(..)
, Transaction(..)
, transactionToPostings
, views
, unrollSnd
) where
import Control.Applicative
import Control.Arrow (second)
import Data.Binary (Binary)
import GHC.Generics (Generic)
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 (isNothing, catMaybes)
import qualified Data.Traversable as Tr
import qualified Data.Foldable as Fdbl
data Inferred = Inferred | NotInferred
deriving (Eq, Ord, Show, Generic)
instance Binary Inferred
data Ent m = Ent
{ entry :: B.Entry
, inferred :: Inferred
, meta :: m
} deriving (Eq, Ord, Show, Generic)
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 i m) = Ent e i (f m)
instance Binary m => Binary (Ent m)
newtype Ents m = Ents { unEnts :: [Ent m] }
deriving (Eq, Ord, Show, Generic, 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 <*> pure i <*> f en
seqEnt :: Applicative f => Ent (f a) -> f (Ent a)
seqEnt (Ent e i m) = Ent <$> pure e <*> pure i <*> m
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"
instance Binary m => Binary (Ents m)
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 B.Entry, m)]
-> Maybe (Ents m)
ents ls = do
guard . not . null $ ls
let makePstg = makeEnt (inferredVal . map fst $ ls)
fmap Ents $ mapM makePstg ls
rEnts
:: B.Commodity
-> B.DrCr
-> (B.Qty, m)
-> [(B.Qty, m)]
-> m
-> Ents m
rEnts com dc (q1, m1) nonInfs lastMeta =
let tot = foldl' B.add q1 . map fst $ nonInfs
p1 = makePstg (q1, m1)
ps = map makePstg nonInfs
makePstg (q, m) = Ent (B.Entry dc (B.Amount q com))
NotInferred m
lastPstg = Ent (B.Entry (B.opposite dc) (B.Amount tot com))
Inferred lastMeta
in Ents $ p1:ps ++ [lastPstg]
makeEnt
:: Maybe B.Entry
-> (Maybe B.Entry, m)
-> Maybe (Ent m)
makeEnt mayInf (mayEn, m) = case mayEn of
Nothing -> case mayInf of
Nothing -> Nothing
Just inf -> return $ Ent inf Inferred m
Just en -> return $ Ent en NotInferred m
inferredVal :: [Maybe B.Entry] -> Maybe B.Entry
inferredVal ls = do
guard ((length . filter id . map isNothing $ ls) == 1)
let bal = mconcat
. map Bal.entryToBalance
. catMaybes
$ ls
case Bal.isBalanced bal of
Bal.Inferable e -> Just e
_ -> Nothing