-- 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]
-}

{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing 
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
compileBlocks dfrom duntil []             = [(dfrom, duntil)]
compileBlocks dfrom duntil [(d,False)]                              
  | dend <- min duntil d, dfrom < dend    = [(dfrom, dend)] -- redundant, but common case
  | otherwise                             = []
compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
  | u1 == u2                              =               compileBlocks dfrom      duntil (p1:bs)   -- superfluous block/unblock
  | d1 == d2                              =               compileBlocks dfrom      duntil (p2:bs)   -- eliminate same day changes
  | 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) 
  | dfrom >= d =               compileBlocks dfrom      duntil     bs    -- should only occur if blocks/unblock happened on same day 
                                                                                                 

cmpBlocks :: BlockIntervalTest -> [(Day,Day)]
cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks
  where 
    cleanBlocks ((_,True):r) = cleanBlocks r
    cleanBlocks (b1@(d1,False):b2@(d2,True):r)
      | d1 < d1   = b1:b2:cleanBlocks r
      | otherwise =       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 "works on examples" . example $ do
      let wA = fromGregorian 2002  1 11
          wE = fromGregorian 2025  4 30
          w0 = fromGregorian 2001  9 22
          w1 = fromGregorian 2023  9 22
          w2 = fromGregorian 2023 10 16
          wF = fromGregorian 2023 10 17
          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,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)]
      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)]
      compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
      compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
      compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)]  `shouldBe` [(wA,w2),(w3,wE)]
      compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
      compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]

    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)
      b3 <- generate arbitrary
      b4 <- generate arbitrary
      let test   = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
          result | b3, b4       = [(d1, d2)]
                 | b3           = [(d1, min d2 d4)]                 
                 | b4, d2 > d4  = [(d1,d3),(d4,d2)]
                 | otherwise    = [(d1, min d2 d3)]
      test `shouldBe` result