{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-|

A 'PeriodicTransaction' is a rule describing recurring transactions.

-}
module Hledger.Data.PeriodicTransaction (
    runPeriodicTransaction
  , checkPeriodicTransactionStartDate
)
where

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Text.Printf

import Hledger.Data.Types
import Hledger.Data.Dates
import Hledger.Data.Amount
import Hledger.Data.Posting (post, commentAddTagNextLine)
import Hledger.Data.Transaction
import Hledger.Utils.UTF8IOCompat (error')
import Hledger.Utils.Debug

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Hledger.Data.Posting
-- >>> import Hledger.Data.Journal

-- doctest helper, too much hassle to define in the comment
-- XXX duplicates some logic in periodictransactionp
_ptgen :: [Char] -> IO ()
_ptgen [Char]
str = do
  let
    t :: Text
t = [Char] -> Text
T.pack [Char]
str
    (Interval
i,DateSpan
s) = Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' Day
nulldate Text
t
  case Interval -> DateSpan -> Text -> Maybe [Char]
checkPeriodicTransactionStartDate Interval
i DateSpan
s Text
t of
    Just [Char]
e  -> [Char] -> IO ()
forall a. [Char] -> a
error' [Char]
e  -- PARTIAL:
    Maybe [Char]
Nothing ->
      (Transaction -> IO ()) -> [Transaction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
T.putStr (Text -> IO ()) -> (Transaction -> Text) -> Transaction -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> Text
showTransaction) ([Transaction] -> IO ()) -> [Transaction] -> IO ()
forall a b. (a -> b) -> a -> b
$
        PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction
          PeriodicTransaction
nullperiodictransaction{ ptperiodexpr :: Text
ptperiodexpr=Text
t , ptspan :: DateSpan
ptspan=DateSpan
s, ptinterval :: Interval
ptinterval=Interval
i, ptpostings :: [Posting]
ptpostings=[Text
"a" Text -> Amount -> Posting
`post` DecimalRaw Integer -> Amount
usd DecimalRaw Integer
1] }
          DateSpan
nulldatespan

_ptgenspan :: [Char] -> DateSpan -> IO ()
_ptgenspan [Char]
str DateSpan
span = do
  let
    t :: Text
t = [Char] -> Text
T.pack [Char]
str
    (Interval
i,DateSpan
s) = Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' Day
nulldate Text
t
  case Interval -> DateSpan -> Text -> Maybe [Char]
checkPeriodicTransactionStartDate Interval
i DateSpan
s Text
t of
    Just [Char]
e  -> [Char] -> IO ()
forall a. [Char] -> a
error' [Char]
e  -- PARTIAL:
    Maybe [Char]
Nothing ->
      (Transaction -> IO ()) -> [Transaction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
T.putStr (Text -> IO ()) -> (Transaction -> Text) -> Transaction -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> Text
showTransaction) ([Transaction] -> IO ()) -> [Transaction] -> IO ()
forall a b. (a -> b) -> a -> b
$
        PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction
          PeriodicTransaction
nullperiodictransaction{ ptperiodexpr :: Text
ptperiodexpr=Text
t , ptspan :: DateSpan
ptspan=DateSpan
s, ptinterval :: Interval
ptinterval=Interval
i, ptpostings :: [Posting]
ptpostings=[Text
"a" Text -> Amount -> Posting
`post` DecimalRaw Integer -> Amount
usd DecimalRaw Integer
1] }
          DateSpan
span

--deriving instance Show PeriodicTransaction
-- for better pretty-printing:
instance Show PeriodicTransaction where
  show :: PeriodicTransaction -> [Char]
show PeriodicTransaction{[Tag]
[Posting]
Text
Status
Interval
DateSpan
pttags :: PeriodicTransaction -> [Tag]
ptcomment :: PeriodicTransaction -> Text
ptdescription :: PeriodicTransaction -> Text
ptcode :: PeriodicTransaction -> Text
ptstatus :: PeriodicTransaction -> Status
ptpostings :: [Posting]
pttags :: [Tag]
ptcomment :: Text
ptdescription :: Text
ptcode :: Text
ptstatus :: Status
ptspan :: DateSpan
ptinterval :: Interval
ptperiodexpr :: Text
ptpostings :: PeriodicTransaction -> [Posting]
ptinterval :: PeriodicTransaction -> Interval
ptspan :: PeriodicTransaction -> DateSpan
ptperiodexpr :: PeriodicTransaction -> Text
..} =
    [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s}"
      ([Char]
"ptperiodexpr=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ptperiodexpr)
      ([Char]
"ptinterval=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Interval -> [Char]
forall a. Show a => a -> [Char]
show Interval
ptinterval)
      ([Char]
"ptspan=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show (DateSpan -> [Char]
forall a. Show a => a -> [Char]
show DateSpan
ptspan))
      ([Char]
"ptstatus=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show (Status -> [Char]
forall a. Show a => a -> [Char]
show Status
ptstatus))
      ([Char]
"ptcode=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ptcode)
      ([Char]
"ptdescription=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ptdescription)
      ([Char]
"ptcomment=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ptcomment)
      ([Char]
"pttags=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Tag] -> [Char]
forall a. Show a => a -> [Char]
show [Tag]
pttags)
      ([Char]
"ptpostings=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Posting] -> [Char]
forall a. Show a => a -> [Char]
show [Posting]
ptpostings)

-- A basic human-readable rendering.
--showPeriodicTransaction t = "~ " ++ T.unpack (ptperiodexpr t) ++ "\n" ++ unlines (map show (ptpostings t))

--nullperiodictransaction is defined in Types.hs

-- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'
--
-- Note that new transactions require 'txnTieKnot' post-processing.
-- The new transactions will have three tags added: 
-- - a recur:PERIODICEXPR tag whose value is the generating periodic expression
-- - a generated-transaction: tag
-- - a hidden _generated-transaction: tag which does not appear in the comment. 
--
-- >>> import Data.Time (fromGregorian)
-- >>> _ptgen "monthly from 2017/1 to 2017/4"
-- 2017-01-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
-- 2017-02-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
-- 2017-03-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "monthly from 2017/1 to 2017/5"
-- 2017-01-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-02-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-03-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-04-01
--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"
-- 2017-01-02
--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
--     a           $1.00
-- <BLANKLINE>
-- 2017-02-02
--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
--     a           $1.00
-- <BLANKLINE>
-- 2017-03-02
--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"
-- 2016-12-30
--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-01-30
--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-02-28
--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-03-30
--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
-- 2017-04-30
--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"
-- 2016-12-08
--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
-- 2017-01-12
--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
-- 2017-02-09
--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
-- 2017-03-09
--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "every nov 29th from 2017 to 2019"
-- 2016-11-29
--     ; generated-transaction: ~ every nov 29th from 2017 to 2019
--     a           $1.00
-- <BLANKLINE>
-- 2017-11-29
--     ; generated-transaction: ~ every nov 29th from 2017 to 2019
--     a           $1.00
-- <BLANKLINE>
-- 2018-11-29
--     ; generated-transaction: ~ every nov 29th from 2017 to 2019
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen "2017/1"
-- 2017-01-01
--     ; generated-transaction: ~ 2017/1
--     a           $1.00
-- <BLANKLINE>
--
-- >>> _ptgen ""
-- *** Exception: failed to parse...
-- ...
--
-- >>> _ptgen "weekly from 2017"
-- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the Week
--
-- >>> _ptgen "monthly from 2017/5/4"
-- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the Month
--
-- >>> _ptgen "every quarter from 2017/1/2"
-- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the Quarter
--
-- >>> _ptgen "yearly from 2017/1/14"
-- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the Year
--
-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 03))
-- []
--
-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ fromGregorian 2020 01 01) (Just $ fromGregorian 2020 02 01))
--
-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ fromGregorian 2020 02 01) (Just $ fromGregorian 2020 03 01))
-- 2020-02-01
--     ; generated-transaction: ~ every 3 months from 2019-05
--     a           $1.00
-- <BLANKLINE>
-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 05))
-- 2018-01-01
--     ; generated-transaction: ~ every 3 days from 2018
--     a           $1.00
-- <BLANKLINE>
-- 2018-01-04
--     ; generated-transaction: ~ every 3 days from 2018
--     a           $1.00
-- <BLANKLINE>
-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ fromGregorian 2018 01 02) (Just $ fromGregorian 2018 01 05))
-- 2018-01-04
--     ; generated-transaction: ~ every 3 days from 2018
--     a           $1.00
-- <BLANKLINE>

runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction PeriodicTransaction{[Tag]
[Posting]
Text
Status
Interval
DateSpan
ptpostings :: [Posting]
pttags :: [Tag]
ptcomment :: Text
ptdescription :: Text
ptcode :: Text
ptstatus :: Status
ptspan :: DateSpan
ptinterval :: Interval
ptperiodexpr :: Text
pttags :: PeriodicTransaction -> [Tag]
ptcomment :: PeriodicTransaction -> Text
ptdescription :: PeriodicTransaction -> Text
ptcode :: PeriodicTransaction -> Text
ptstatus :: PeriodicTransaction -> Status
ptpostings :: PeriodicTransaction -> [Posting]
ptinterval :: PeriodicTransaction -> Interval
ptspan :: PeriodicTransaction -> DateSpan
ptperiodexpr :: PeriodicTransaction -> Text
..} DateSpan
requestedspan =
    [ Transaction
t{tdate :: Day
tdate=Day
d} | (DateSpan (Just Day
d) Maybe Day
_) <- [DateSpan]
alltxnspans, DateSpan -> Day -> Bool
spanContainsDate DateSpan
requestedspan Day
d ]
  where
    t :: Transaction
t = Transaction
nulltransaction{
           tstatus :: Status
tstatus      = Status
ptstatus
          ,tcode :: Text
tcode        = Text
ptcode
          ,tdescription :: Text
tdescription = Text
ptdescription
          ,tcomment :: Text
tcomment     = Text
ptcomment
                          Text -> Tag -> Text
`commentAddTagNextLine` (Text
"generated-transaction",Text
period)
          ,ttags :: [Tag]
ttags        = (Text
"_generated-transaction",Text
period) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                          (Text
"generated-transaction" ,Text
period) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                          [Tag]
pttags
          ,tpostings :: [Posting]
tpostings    = [Posting]
ptpostings
          }
    period :: Text
period = Text
"~ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptperiodexpr
    -- All spans described by this periodic transaction, where spanStart is event date.
    -- If transaction does not have start/end date, we set them to start/end of requested span,
    -- to avoid generating (infinitely) many events. 
    alltxnspans :: [DateSpan]
alltxnspans = [Char] -> [DateSpan] -> [DateSpan]
forall a. Show a => [Char] -> a -> a
dbg3 [Char]
"alltxnspans" ([DateSpan] -> [DateSpan]) -> [DateSpan] -> [DateSpan]
forall a b. (a -> b) -> a -> b
$ Interval
ptinterval Interval -> DateSpan -> [DateSpan]
`splitSpan` (DateSpan -> DateSpan -> DateSpan
spanDefaultsFrom DateSpan
ptspan DateSpan
requestedspan)

-- | Check that this date span begins at a boundary of this interval,
-- or return an explanatory error message including the provided period expression
-- (from which the span and interval are derived).
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> Text -> Maybe [Char]
checkPeriodicTransactionStartDate Interval
i DateSpan
s Text
periodexpr =
  case (Interval
i, DateSpan -> Maybe Day
spanStart DateSpan
s) of
    (Weeks Int
_,    Just Day
d) -> Day -> SmartInterval -> Maybe [Char]
checkStart Day
d SmartInterval
Week
    (Months Int
_,   Just Day
d) -> Day -> SmartInterval -> Maybe [Char]
checkStart Day
d SmartInterval
Month
    (Quarters Int
_, Just Day
d) -> Day -> SmartInterval -> Maybe [Char]
checkStart Day
d SmartInterval
Quarter
    (Years Int
_,    Just Day
d) -> Day -> SmartInterval -> Maybe [Char]
checkStart Day
d SmartInterval
Year
    (Interval, Maybe Day)
_                    -> Maybe [Char]
forall a. Maybe a
Nothing
    where
      checkStart :: Day -> SmartInterval -> Maybe [Char]
checkStart Day
d SmartInterval
x =
        let firstDate :: Day
firstDate = Day -> SmartDate -> Day
fixSmartDate Day
d (SmartDate -> Day) -> SmartDate -> Day
forall a b. (a -> b) -> a -> b
$ SmartSequence -> SmartInterval -> SmartDate
SmartRelative SmartSequence
This SmartInterval
x
        in
         if Day
d Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
firstDate
         then Maybe [Char]
forall a. Maybe a
Nothing
         else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
          [Char]
"Unable to generate transactions according to "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
forall a. Show a => a -> [Char]
show (Text -> [Char]
T.unpack Text
periodexpr)
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" because "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Day -> [Char]
forall a. Show a => a -> [Char]
show Day
d[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" is not a first day of the "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++SmartInterval -> [Char]
forall a. Show a => a -> [Char]
show SmartInterval
x

---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?
--periodTransactionInterval :: PeriodicTransaction -> Maybe Interval
--periodTransactionInterval pt =
--  let
--    expr = ptperiodexpr pt
--    err  = error' $ "Current date cannot be referenced in " ++ show (T.unpack expr)
--  in
--    case parsePeriodExpr err expr of
--      Left _      -> Nothing
--      Right (i,_) -> Just i