hledger/hledger-lib/Hledger/Data/PeriodicTransaction.hs

{-# 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.Monoid ((<>))
#endif
import qualified Data.Text 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 str = do
  let
    t = T.pack str
    (i,s) = parsePeriodExpr' nulldate t
  case checkPeriodicTransactionStartDate i s t of
    Just e  -> error' e  -- PARTIAL:
    Nothing ->
      mapM_ (putStr . showTransaction) $
        runPeriodicTransaction
          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
          nulldatespan

_ptgenspan str span = do
  let
    t = T.pack str
    (i,s) = parsePeriodExpr' nulldate t
  case checkPeriodicTransactionStartDate i s t of
    Just e  -> error' e  -- PARTIAL:
    Nothing ->
      mapM_ (putStr . showTransaction) $
        runPeriodicTransaction
          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
          span

--deriving instance Show PeriodicTransaction
-- for better pretty-printing:
instance Show PeriodicTransaction where
  show PeriodicTransaction{..} =
    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s}"
      ("ptperiodexpr=" ++ show ptperiodexpr)
      ("ptinterval=" ++ show ptinterval)
      ("ptspan=" ++ show (show ptspan))
      ("ptstatus=" ++ show (show ptstatus))
      ("ptcode=" ++ show ptcode)
      ("ptdescription=" ++ show ptdescription)
      ("ptcomment=" ++ show ptcomment)
      ("pttags=" ++ show pttags)
      ("ptpostings=" ++ show 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. 
--
-- >>> _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 $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))
-- []
--
-- >>> _ptgenspan "every 3 months from 2019-05" (mkdatespan "2020-01-01" "2020-02-01")
--  
-- >>> _ptgenspan "every 3 months from 2019-05" (mkdatespan "2020-02-01" "2020-03-01")
-- 2020-02-01
--     ; generated-transaction: ~ every 3 months from 2019-05
--     a           $1.00
-- <BLANKLINE>
-- >>> _ptgenspan "every 3 days from 2018" (mkdatespan "2018-01-01" "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" (mkdatespan "2018-01-02" "2018-01-05")
-- 2018-01-04
--     ; generated-transaction: ~ every 3 days from 2018
--     a           $1.00
-- <BLANKLINE>

runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction PeriodicTransaction{..} requestedspan =
    [ t{tdate=d} | (DateSpan (Just d) _) <- alltxnspans, spanContainsDate requestedspan d ]
  where
    t = nulltransaction{
           tstatus      = ptstatus
          ,tcode        = ptcode
          ,tdescription = ptdescription
          ,tcomment     = ptcomment
                          `commentAddTagNextLine` ("generated-transaction",period)
          ,ttags        = ("_generated-transaction",period) :
                          ("generated-transaction" ,period) :
                          pttags
          ,tpostings    = ptpostings
          }
    period = "~ " <> 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 = dbg3 "alltxnspans" $ ptinterval `splitSpan` (spanDefaultsFrom ptspan 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 i s periodexpr =
  case (i, spanStart s) of
    (Weeks _,    Just d) -> checkStart d Week
    (Months _,   Just d) -> checkStart d Month
    (Quarters _, Just d) -> checkStart d Quarter
    (Years _,    Just d) -> checkStart d Year
    _                    -> Nothing
    where
      checkStart d x =
        let firstDate = fixSmartDate d $ SmartRelative This x
        in
         if d == firstDate
         then Nothing
         else Just $
          "Unable to generate transactions according to "++show (T.unpack periodexpr)
          ++" because "++show d++" is not a first day of the "++show 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