lib: refactor runPeriodicTransaction, add a test

hledger-lib/Hledger/Data/AutoTransaction.hs

@@ -33,6 +33,7 @@ import Hledger.Data.Transaction
 import Hledger.Utils.Parse
 import Hledger.Utils.UTF8IOCompat (error')
 import Hledger.Query
+-- import Hledger.Utils.Debug
 
 -- $setup
 -- >>> :set -XOverloadedStrings
@@ -238,29 +239,37 @@ renderPostingCommentDates p = p { pcomment = comment' }
 -- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" as 2017-01-02 is not a first day of the quarter        
 -- >>> gen "yearly from 2017/1/14"
 -- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" as 2017-01-14 is not a first day of the year        
+--
+-- >>> let reportperiod="daily from 2018/01/03" in runPeriodicTransaction (PeriodicTransaction reportperiod [post "a" (usd 1)]) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))
+-- []
 runPeriodicTransaction :: PeriodicTransaction -> (DateSpan -> [Transaction])
-runPeriodicTransaction pt = generate where
+runPeriodicTransaction pt =
-    base = nulltransaction { tpostings = ptpostings pt }
+  \requestedspan ->
-    periodExpr = ptperiodicexpr pt
+    let fillspan = ptspan `spanIntersect` requestedspan
-    errCurrent = error' $ "Current date cannot be referenced in " ++ show (T.unpack periodExpr)
+    in  [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` fillspan ]
-    (interval, effectspan) =
+  where
-        case parsePeriodExpr errCurrent periodExpr of
+    t = nulltransaction { tpostings = ptpostings pt }
-            Left e -> error' $ "Failed to parse " ++ show (T.unpack periodExpr) ++ ": " ++ showDateParseError e
+    periodexpr = ptperiodicexpr pt
-            Right x -> checkProperStartDate x
+    currentdateerr = error' $ "Current date cannot be referenced in " ++ show (T.unpack periodexpr)
-    generate jspan = [base {tdate=date} | span <- interval `splitSpan` spanIntersect effectspan jspan, let Just date = spanStart span]
+    (ptinterval, ptspan) =
-    checkProperStartDate (i,s) = 
+        case parsePeriodExpr currentdateerr periodexpr of
-      case (i,spanStart s) of
+            Left e  -> error' $ "Failed to parse " ++ show (T.unpack periodexpr) ++ ": " ++ showDateParseError e
-        (Weeks _,    Just d) -> checkStart d "week"
+            Right x -> checkPeriodTransactionStartDate periodexpr x
-        (Months _,   Just d) -> checkStart d "month"
+
-        (Quarters _, Just d) -> checkStart d "quarter"
+checkPeriodTransactionStartDate :: T.Text -> (Interval, DateSpan) -> (Interval, DateSpan)
-        (Years _,    Just d) -> checkStart d "year"
+checkPeriodTransactionStartDate periodexpr (i,s) = 
-        _                    -> (i,s) 
+  case (i,spanStart s) of
-        where
+    (Weeks _,    Just d) -> checkStart d "week"
-          checkStart d x =
+    (Months _,   Just d) -> checkStart d "month"
-            let firstDate = fixSmartDate d ("","this",x) 
+    (Quarters _, Just d) -> checkStart d "quarter"
-            in   
+    (Years _,    Just d) -> checkStart d "year"
-             if d == firstDate then (i,s)
+    _                    -> (i,s) 
-             else error' $ "Unable to generate transactions according to "++(show periodExpr)++" as "++(show d)++" is not a first day of the "++x
+    where
+      checkStart d x =
+        let firstDate = fixSmartDate d ("","this",x) 
+        in   
+         if d == firstDate then (i,s)
+         else error' $ "Unable to generate transactions according to "++(show periodexpr)++" as "++(show d)++" is not a first day of the "++x
 
 -- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?
 periodTransactionInterval :: PeriodicTransaction -> Maybe Interval