{-# LANGUAGE CPP #-}
{-|


Data values for zero or more report periods, and for the pre-report period.
Report periods are assumed to be contiguous, and represented only by start dates
(as keys of an IntMap).

-}
module Hledger.Data.PeriodData
( periodDataFromList
, periodDataToList

, lookupPeriodData
, lookupPeriodDataOrHistorical
, insertPeriodData
, opPeriodData
, mergePeriodData
, padPeriodData

, tests_PeriodData
) where

#if MIN_VERSION_base(4,18,0)
import Data.Foldable1 (Foldable1(..))
#else
import Control.Applicative (liftA2)
#endif
#if !MIN_VERSION_base(4,20,0)
import Data.List (foldl')
#endif
import Data.Map qualified as M
import Data.Time (Day (..), fromGregorian)

import Hledger.Data.Amount
import Hledger.Data.Types
import Hledger.Utils


instance Show a => Show (PeriodData a) where
  showsPrec :: Int -> PeriodData a -> ShowS
showsPrec Int
d (PeriodData a
h Map Day a
ds) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"PeriodData"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"{ pdpre = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
h
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", pdperiods = "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"fromList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Day, a)] -> ShowS
forall a. Show a => a -> ShowS
shows (Map Day a -> [(Day, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map Day a
ds)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'

instance Foldable PeriodData where
  foldr :: forall a b. (a -> b -> b) -> b -> PeriodData a -> b
foldr a -> b -> b
f b
z (PeriodData a
h Map Day a
as) = (a -> b -> b) -> b -> Map Day a -> b
forall a b. (a -> b -> b) -> b -> Map Day a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f (a -> b -> b
f a
h b
z) Map Day a
as
  foldl :: forall b a. (b -> a -> b) -> b -> PeriodData a -> b
foldl b -> a -> b
f b
z (PeriodData a
h Map Day a
as) = (b -> a -> b) -> b -> Map Day a -> b
forall b a. (b -> a -> b) -> b -> Map Day a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> a -> b
f (b -> a -> b
f b
z a
h) Map Day a
as
  foldl' :: forall b a. (b -> a -> b) -> b -> PeriodData a -> b
foldl' b -> a -> b
f b
z (PeriodData a
h Map Day a
as) = let fzh :: b
fzh = b -> a -> b
f b
z a
h in b
fzh b -> b -> b
forall a b. a -> b -> b
`seq` (b -> a -> b) -> b -> Map Day a -> b
forall b a. (b -> a -> b) -> b -> Map Day a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> a -> b
f b
fzh Map Day a
as

#if MIN_VERSION_base(4,18,0)
instance Foldable1 PeriodData where
  foldrMap1 :: forall a b. (a -> b) -> (a -> b -> b) -> PeriodData a -> b
foldrMap1 a -> b
f a -> b -> b
g (PeriodData a
h Map Day a
as) = (a -> b -> b) -> b -> Map Day a -> b
forall a b. (a -> b -> b) -> b -> Map Day a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
g (a -> b
f a
h) Map Day a
as
  foldlMap1 :: forall a b. (a -> b) -> (b -> a -> b) -> PeriodData a -> b
foldlMap1 a -> b
f b -> a -> b
g (PeriodData a
h Map Day a
as) = (b -> a -> b) -> b -> Map Day a -> b
forall b a. (b -> a -> b) -> b -> Map Day a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> a -> b
g (a -> b
f a
h) Map Day a
as
  foldlMap1' :: forall a b. (a -> b) -> (b -> a -> b) -> PeriodData a -> b
foldlMap1' a -> b
f b -> a -> b
g (PeriodData a
h Map Day a
as) = let fh :: b
fh = a -> b
f a
h in b
fh b -> b -> b
forall a b. a -> b -> b
`seq` (b -> a -> b) -> b -> Map Day a -> b
forall b a. (b -> a -> b) -> b -> Map Day a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> a -> b
g b
fh Map Day a
as
#endif

instance Traversable PeriodData where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PeriodData a -> f (PeriodData b)
traverse a -> f b
f (PeriodData a
h Map Day a
as) = (b -> Map Day b -> PeriodData b)
-> f b -> f (Map Day b) -> f (PeriodData b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> Map Day b -> PeriodData b
forall a. a -> Map Day a -> PeriodData a
PeriodData (a -> f b
f a
h) (f (Map Day b) -> f (PeriodData b))
-> f (Map Day b) -> f (PeriodData b)
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> Map Day a -> f (Map Day b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Day a -> f (Map Day b)
traverse a -> f b
f Map Day a
as

-- | The Semigroup instance for 'PeriodData' simply takes the union of
-- keys in the date map section. This may not be the result you want if the
-- keys are not identical.
instance Semigroup a => Semigroup (PeriodData a) where
  PeriodData a
h1 Map Day a
as1 <> :: PeriodData a -> PeriodData a -> PeriodData a
<> PeriodData a
h2 Map Day a
as2 = a -> Map Day a -> PeriodData a
forall a. a -> Map Day a -> PeriodData a
PeriodData (a
h1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
h2) (Map Day a -> PeriodData a) -> Map Day a -> PeriodData a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> Map Day a -> Map Day a -> Map Day a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) Map Day a
as1 Map Day a
as2

instance Monoid a => Monoid (PeriodData a) where
  mempty :: PeriodData a
mempty = a -> Map Day a -> PeriodData a
forall a. a -> Map Day a -> PeriodData a
PeriodData a
forall a. Monoid a => a
mempty Map Day a
forall a. Monoid a => a
mempty

-- | Construct a 'PeriodData' from a historical data value and a list of (period start, period data) pairs.
periodDataFromList :: a -> [(Day, a)] -> PeriodData a
periodDataFromList :: forall a. a -> [(Day, a)] -> PeriodData a
periodDataFromList a
h = a -> Map Day a -> PeriodData a
forall a. a -> Map Day a -> PeriodData a
PeriodData a
h (Map Day a -> PeriodData a)
-> ([(Day, a)] -> Map Day a) -> [(Day, a)] -> PeriodData a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Day, a)] -> Map Day a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

-- | Convert 'PeriodData' to a historical data value and a list of (period start, period data) pairs.
periodDataToList :: PeriodData a -> (a, [(Day, a)])
periodDataToList :: forall a. PeriodData a -> (a, [(Day, a)])
periodDataToList (PeriodData a
h Map Day a
as) = (a
h, Map Day a -> [(Day, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map Day a
as)

-- | Get the data for the period containing the given 'Day', and that period's start date.
-- If the day is after the end of the last period, it is assumed to be within the last period.
-- If the day is before the start of the first period (ie, in the historical period), return Nothing.
lookupPeriodData :: Day -> PeriodData a -> Maybe (Day, a)
lookupPeriodData :: forall a. Day -> PeriodData a -> Maybe (Day, a)
lookupPeriodData Day
d (PeriodData a
_ Map Day a
as) = Day -> Map Day a -> Maybe (Day, a)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
M.lookupLE Day
d Map Day a
as

-- | Get the data for the period containing the given 'Day', and that period's start date.
-- If the day is after the end of the last period, it is assumed to be within the last period.
-- If the day is before the start of the first period (ie, in the historical period),
-- return the data for the historical period and no start date.
lookupPeriodDataOrHistorical :: Day -> PeriodData a -> (Maybe Day, a)
lookupPeriodDataOrHistorical :: forall a. Day -> PeriodData a -> (Maybe Day, a)
lookupPeriodDataOrHistorical Day
d pd :: PeriodData a
pd@(PeriodData a
h Map Day a
_) = case Day -> PeriodData a -> Maybe (Day, a)
forall a. Day -> PeriodData a -> Maybe (Day, a)
lookupPeriodData Day
d PeriodData a
pd of
  Maybe (Day, a)
Nothing     -> (Maybe Day
forall a. Maybe a
Nothing, a
h)
  Just (Day
a, a
b) -> (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
a, a
b)

-- | Set historical or period data in the appropriate location in a 'PeriodData'.
insertPeriodData :: Semigroup a => Maybe Day -> a -> PeriodData a -> PeriodData a
insertPeriodData :: forall a.
Semigroup a =>
Maybe Day -> a -> PeriodData a -> PeriodData a
insertPeriodData Maybe Day
mday a
b PeriodData a
balances = case Maybe Day
mday of
    Maybe Day
Nothing  -> PeriodData a
balances{pdpre = pdpre balances <> b}
    Just Day
day -> PeriodData a
balances{pdperiods = M.insertWith (<>) day b $ pdperiods balances}

-- | Merge two 'PeriodData', using the given operation to combine their data values.
--
-- This will drop keys if they are not present in both 'PeriodData'.
opPeriodData :: (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c
opPeriodData :: forall a b c.
(a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c
opPeriodData a -> b -> c
f (PeriodData a
h1 Map Day a
as1) (PeriodData b
h2 Map Day b
as2) =
  c -> Map Day c -> PeriodData c
forall a. a -> Map Day a -> PeriodData a
PeriodData (a -> b -> c
f a
h1 b
h2) (Map Day c -> PeriodData c) -> Map Day c -> PeriodData c
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> Map Day a -> Map Day b -> Map Day c
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith a -> b -> c
f Map Day a
as1 Map Day b
as2

-- | Merge two 'PeriodData', using the given operations for combining data
-- that's only in the first, only in the second, or in both, respectively.
mergePeriodData :: (a -> c) -> (b -> c) -> (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c
mergePeriodData :: forall a c b.
(a -> c)
-> (b -> c)
-> (a -> b -> c)
-> PeriodData a
-> PeriodData b
-> PeriodData c
mergePeriodData a -> c
only1 b -> c
only2 a -> b -> c
f = \(PeriodData a
h1 Map Day a
as1) (PeriodData b
h2 Map Day b
as2) ->
  c -> Map Day c -> PeriodData c
forall a. a -> Map Day a -> PeriodData a
PeriodData (a -> b -> c
f a
h1 b
h2) (Map Day c -> PeriodData c) -> Map Day c -> PeriodData c
forall a b. (a -> b) -> a -> b
$ Map Day a -> Map Day b -> Map Day c
merge Map Day a
as1 Map Day b
as2
  where
    merge :: Map Day a -> Map Day b -> Map Day c
merge = (Day -> a -> b -> Maybe c)
-> (Map Day a -> Map Day c)
-> (Map Day b -> Map Day c)
-> Map Day a
-> Map Day b
-> Map Day c
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
M.mergeWithKey (\Day
_ a
x b
y -> c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> c -> Maybe c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
x b
y) ((a -> c) -> Map Day a -> Map Day c
forall a b. (a -> b) -> Map Day a -> Map Day b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> c
only1) ((b -> c) -> Map Day b -> Map Day c
forall a b. (a -> b) -> Map Day a -> Map Day b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
only2)

-- | Pad out the date map of a 'PeriodData' so that every key from another 'PeriodData' is present.
padPeriodData :: a -> PeriodData b -> PeriodData a -> PeriodData a
padPeriodData :: forall a b. a -> PeriodData b -> PeriodData a -> PeriodData a
padPeriodData a
x PeriodData b
pad PeriodData a
bal = PeriodData a
bal{pdperiods = pdperiods bal <> (x <$ pdperiods pad)}


-- tests

tests_PeriodData :: TestTree
tests_PeriodData =
  let
    dayMap :: PeriodData MixedAmount
dayMap  = MixedAmount -> [(Day, MixedAmount)] -> PeriodData MixedAmount
forall a. a -> [(Day, a)] -> PeriodData a
periodDataFromList ([Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
1]) [(Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
01 Int
01, [Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
2]), (Integer -> Int -> Int -> Day
fromGregorian Integer
2004 Int
02 Int
28, [Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
3])]
    dayMap2 :: PeriodData MixedAmount
dayMap2 = MixedAmount -> [(Day, MixedAmount)] -> PeriodData MixedAmount
forall a. a -> [(Day, a)] -> PeriodData a
periodDataFromList ([Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
2]) [(Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
01 Int
01, [Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
4]), (Integer -> Int -> Int -> Day
fromGregorian Integer
2004 Int
02 Int
28, [Amount] -> MixedAmount
forall (t :: * -> *). Foldable t => t Amount -> MixedAmount
mixed [DecimalRaw Integer -> Amount
usd DecimalRaw Integer
6])]
  in String -> [TestTree] -> TestTree
testGroup String
"PeriodData" [

       String -> Assertion -> TestTree
testCase String
"periodDataFromList" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
         PeriodData MixedAmount -> Int
forall a. PeriodData a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PeriodData MixedAmount
dayMap Int -> Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int
3,

       String -> Assertion -> TestTree
testCase String
"Semigroup instance" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
         PeriodData MixedAmount
dayMap PeriodData MixedAmount
-> PeriodData MixedAmount -> PeriodData MixedAmount
forall a. Semigroup a => a -> a -> a
<> PeriodData MixedAmount
dayMap PeriodData MixedAmount -> PeriodData MixedAmount -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= PeriodData MixedAmount
dayMap2,

       String -> Assertion -> TestTree
testCase String
"Monoid instance" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
         PeriodData MixedAmount
dayMap PeriodData MixedAmount
-> PeriodData MixedAmount -> PeriodData MixedAmount
forall a. Semigroup a => a -> a -> a
<> PeriodData MixedAmount
forall a. Monoid a => a
mempty PeriodData MixedAmount -> PeriodData MixedAmount -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= PeriodData MixedAmount
dayMap
     ]