From f4adfdf87270930d4ca6611f2a9956613fcace53 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 13:57:19 +0200 Subject: [PATCH] fix(sap): combine immediate next day licence chnages for SAP --- src/Handler/SAP.hs | 10 ++++++---- test/Handler/SAPSpec.hs | 37 +++++++++++++++++++++++++++++++------ 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index c22cc58bb..10b71fd9f 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -79,11 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dStart dEnd = go (dStart, True) where go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] - go (d,s) ((d1,s1):r1@((d2,s2):r2)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change + go (d,s) ((d1,s1):r1@((d2,_s2):_r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change go (d,s) ((d1,s1):r1) - | s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found - | otherwise = go (d1,s1) r1 -- ignore invalid interval + | s, not s1 + , d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found + | s == s1 = go (d ,s ) r1 -- no change + | otherwise = go (d1,s1) r1 -- ignore invalid interval go (d,s) [] | s = [(d,dEnd)] | otherwise = [] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index 856bcf001..3f99699cf 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -80,16 +80,41 @@ spec = do w1 = fromGregorian 2023 9 22 w2 = fromGregorian 2023 10 16 w3 = fromGregorian 2023 11 17 + w4 = fromGregorian 2024 01 21 compileBlocks wA wE [] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] - compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] - -- it "yields basic intervals" . property $ - -- \bit@(BlockIntervalTest dFrom dUntil blocks) -> - -- cmpBlocks bit == compileBlocks dFrom dUntil blocks + compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)] + + it "handles basic intervals" $ do + (d1,d2,d3) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + return (d1,d2,d3) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b)] + test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b + + it "identifies two correct intervals" $ do + (d1,d2,d3,d4) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + d4 <- arbitrary `suchThat` (d3 <) + return (d1,d2,d3,d4) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b),(d4,not b)] + result | b = [(d1, min d2 d4)] + | d2 > d4 = [(d1,d3),(d4,d2)] + | otherwise = [(d1, min d2 d3)] + test `shouldBe` result