fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(sap): combine immediate next day licence chnages for SAP

Browse Source
This commit is contained in:
Steffen Jost 2023-10-17 13:57:19 +02:00
parent cbb44f106a
commit f4adfdf872
2 changed files with 37 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Handler/SAP.hs
View File

@ -79,11 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
compileBlocks dStart dEnd = go (dStart, True) compileBlocks dStart dEnd = go (dStart, True)
where where
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
go (d,s) ((d1,s1):r1@((d2,s2):r2)) 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 | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change
go (d,s) ((d1,s1):r1) go (d,s) ((d1,s1):r1)
| s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found | s, not s1
| otherwise = go (d1,s1) r1 -- ignore invalid interval , 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) [] go (d,s) []
| s = [(d,dEnd)] | s = [(d,dEnd)]
| otherwise = [] | otherwise = []

37
test/Handler/SAPSpec.hs
View File

@ -80,16 +80,41 @@ spec = do
w1 = fromGregorian 2023 9 22 w1 = fromGregorian 2023 9 22
w2 = fromGregorian 2023 10 16 w2 = fromGregorian 2023 10 16
w3 = fromGregorian 2023 11 17 w3 = fromGregorian 2023 11 17
w4 = fromGregorian 2024 01 21
compileBlocks wA wE [] `shouldBe` [(wA,wE)] compileBlocks wA wE [] `shouldBe` [(wA,wE)]
compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] 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 [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,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,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),(wA,True),(w1,True)] `shouldBe` [(wA,wE)]
compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] 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),(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)] 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 $ compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
-- \bit@(BlockIntervalTest dFrom dUntil blocks) ->
-- cmpBlocks bit == compileBlocks dFrom dUntil blocks 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