fix(sap): compileBlocks

src/Handler/SAP.hs

@@ -6,6 +6,7 @@
 
 module Handler.SAP
   ( getQualificationSAPDirectR
+  , compileBlocks -- for Test in Handler.SAPSpec only
   )
   where
 
@@ -78,10 +79,10 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
 compileBlocks dfrom duntil []             = [(dfrom,     duntil  )]
 compileBlocks dfrom duntil [(d,False)]    = [(dfrom, min duntil d)] -- redundant, but common case
 compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs)
-  | u1 == u2                              =               compileBlocks dfrom      duntil (p1:bs)   -- superfluous block/unblock
-  | u2, dfrom < d1, d1 < d2, d2 < duntil  = (dfrom, d1) : compileBlocks d2         duntil     bs    -- block and reinstated later
-compileBlocks dfrom duntil ((_,True ):bs) =               compileBlocks dfrom      duntil     bs    -- superfluous unblock
-compileBlocks dfrom duntil ((d,False):bs) =               compileBlocks dfrom (min duntil d)  bs    -- should only occur if blocks/unblock happened on same day 
+  | u1 == u2                              =               compileBlocks dfrom duntil (p1:bs)   -- superfluous block/unblock
+  | u2, dfrom < d1, d1 < d2, d2 < duntil  = (dfrom, d1) : compileBlocks d2    duntil     bs    -- block and reinstated later
+compileBlocks dfrom duntil ((_,True ):bs) =               compileBlocks dfrom duntil     bs    -- superfluous unblock
+compileBlocks dfrom duntil ((_,False):bs) =               compileBlocks dfrom duntil     bs    -- should only occur if blocks/unblock happened on same day 
 
 -- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete
 -- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]

test/Handler/SAPSpec.hs

@@ -0,0 +1,61 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.SAPSpec where
+
+import TestImport
+-- import ModelSpec ()
+-- import CryptoID
+
+import Handler.SAP
+
+
+data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)]
+  deriving (Show, Eq, Ord)
+
+instance Arbitrary BlockIntervalTest where
+  arbitrary = do
+    blocks <- arbitrary
+    case blocks of 
+      [] -> do 
+        dFrom  <- arbitrary
+        dUntil <- arbitrary `suchThat` (dFrom <)
+        return $ BlockIntervalTest dFrom dUntil []
+      ((h,_):t') -> do
+        let ds = ncons h (fst <$> t')
+            dmin = minimum ds
+            dmax = maximum ds
+        dFrom  <- arbitrary `suchThat` (<  dmin)
+        dUntil <- arbitrary `suchThat` (>= dmax)
+        return $ BlockIntervalTest dFrom dUntil $ sort blocks  
+
+  shrink (BlockIntervalTest dFrom dUntil []) 
+    = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU]
+  shrink (BlockIntervalTest dFrom dUntil blocks) 
+    = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b]
+
+
+cmpBlocks :: BlockIntervalTest -> [(Day,Day)]
+cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks
+  where 
+    cleanBlocks ((_,True):r) = cleanBlocks r
+    cleanBlocks (b1@(_,False):b2@(_,True):r) = b1:b2:cleanBlocks r
+    cleanBlocks (b1@(_,False):  (_,False):r) = cleanBlocks (b1:r)
+    cleanBlocks r@[(_,False)] = r
+    cleanBlocks [] = []
+
+    makePeriods a b ((d1,False):(d2,True):r) 
+      | b > d2 = (a,d1):makePeriods d2 b r
+      | otherwise = [(a,d1)]
+    makePeriods a b [(d,False)] = [(a,min b d)]
+    makePeriods a b _ = [(a,b)]
+
+
+
+spec :: Spec
+spec = do 
+  describe "SAP.compileBlocks" $ do
+    it "yields basic intervals" . property $
+      \bit@(BlockIntervalTest dFrom dUntil blocks) -> 
+        cmpBlocks bit == compileBlocks dFrom dUntil blocks