scalendar (empty) → 1.0.0
raw patch · 13 files changed
+1289/−0 lines, 13 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, hspec, scalendar, text, time
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- scalendar.cabal +45/−0
- src/Time/SCalendar/Internal.hs +309/−0
- src/Time/SCalendar/Operations.hs +160/−0
- src/Time/SCalendar/Types.hs +215/−0
- src/Time/SCalendar/Zippers.hs +52/−0
- test/SCalendarTest/Arbitrary.hs +123/−0
- test/SCalendarTest/Constructors.hs +34/−0
- test/SCalendarTest/Helpers.hs +23/−0
- test/SCalendarTest/Internal.hs +138/−0
- test/SCalendarTest/Operations.hs +88/−0
- test/Test.hs +76/−0
+ LICENSE view
@@ -0,0 +1,24 @@+LICENSE++The MIT License++Copyright (c) 2017 Sebastian Pulido Gomez and Stack Builders Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ scalendar.cabal view
@@ -0,0 +1,45 @@+name: scalendar+version: 1.0.0+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1+synopsis: This is a library for handling calendars and resource availability+ based on the "top-nodes algorithm" and set operations.+homepage: https://github.com/stackbuilders/scalendar+license: MIT+license-file: LICENSE+copyright: 2017 Stack Builders Inc.+author: Sebastian Pulido Gómez <spulido@stackbuilders.com>+maintainer: Stack Builders <hackage@stackbuilders.com>+category: Time+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Time.SCalendar.Operations+ , Time.SCalendar.Zippers+ , Time.SCalendar.Types+ , Time.SCalendar.Internal+ build-depends: base >= 4.8 && < 5+ , containers >= 0.5.7.1 && < 0.6+ , time >= 1.5 && < 2+ , text >= 1.2.0.0 && < 2+ default-language: Haskell2010++test-suite scalendar-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ other-modules: SCalendarTest.Internal+ , SCalendarTest.Operations+ , SCalendarTest.Arbitrary+ , SCalendarTest.Helpers+ , SCalendarTest.Constructors+ main-is: Test.hs+ build-depends: base+ , scalendar+ , hspec >= 2.4.2 && < 3.0+ , QuickCheck >= 2.9.2 && < 3.0+ , time+ , containers+ , text+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010
+ src/Time/SCalendar/Internal.hs view
@@ -0,0 +1,309 @@+module Time.SCalendar.Internal+ ( getInterval+ , daysBetween+ , goToNode+ , updateQ+ , intervalFitsCalendar+ , checkQuantAvailability+ , checkReservAvailability+ , updateCalendar+ , topMostNodes+ , leftMostTopNode+ , rightMostTopNode+ , commonParent+ , getZipInterval+ , getQMax+ ) where+++import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Set (Set, union, unions, size, difference, isSubsetOf)+import Data.Maybe (listToMaybe, maybe)+import Control.Monad (guard)+import Time.SCalendar.Zippers+import Time.SCalendar.Types+import qualified Data.Time as TM (diffUTCTime)+++daysBetween :: UTCTime -> UTCTime -> Int+daysBetween from to = 1 + round (TM.diffUTCTime to from / oneDay)++intervalFitsCalendar :: TimePeriod -> Calendar -> Bool+intervalFitsCalendar interval1 (Node interval2 _ _ _ _) =+ isIncluded (toTimeUnit interval1) (toTimeUnit interval2)+intervalFitsCalendar _ _ = False++getInterval :: Calendar -> TimePeriod+getInterval (Unit unit _ _) = unit+getInterval (Node interval _ _ _ _) = toTimeUnit interval++getZipInterval :: CalendarZipper -> TimePeriod+getZipInterval (node, _) = (toTimeUnit . getInterval) node++getQ :: CalendarZipper -> Set Text+getQ (Unit _ q _, _) = q+getQ (Node _ q _ _ _, _) = q++getQN :: CalendarZipper -> Set Text+getQN (Unit _ _ qn, _) = qn+getQN (Node _ _ qn _ _, _) = qn++getQMax :: CalendarZipper -> Maybe (Set Text)+getQMax zipper@(_, []) = Just $ getQ zipper+getQMax zipper = do+ parent <- goUp zipper+ go parent (getQ zipper)+ where+ go zipper@(_, []) sum = do+ let qn = getQN zipper+ return $ union sum qn+ go zipper sum = do+ let qn = getQN zipper+ parent <- goUp zipper+ go parent $ union sum qn++leftMostTopNode :: TimePeriod+ -> Calendar+ -> Maybe CalendarZipper+leftMostTopNode interval calendar = do+ guard $ intervalFitsCalendar interval calendar+ result <- ltmNode (getFrom interval, getTo interval) (toZipper calendar)+ listToMaybe result+ where+ ltmNode (lower, upper) zipper@(Unit t _ _, _)+ | lower == getFrom t && getFrom t <= upper = Just [zipper]+ | otherwise = Just []+ ltmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do+ let (from, to) = (getFrom t, getTo t)+ (lChild, bsl) <- goLeft node+ (rChild, bsr) <- goRight node+ if lower == from && to <= upper+ then Just [node]+ else do+ let toL = (getTo . getInterval) lChild+ fromR = (getFrom . getInterval) rChild+ lAnswer <-+ if lower <= toL+ then ltmNode i (lChild, bsl)+ else Just []+ rAnswer <-+ if lower >= fromR+ then ltmNode i (rChild, bsr)+ else Just []+ return $ lAnswer ++ rAnswer++rightMostTopNode :: TimePeriod+ -> Calendar+ -> Maybe CalendarZipper+rightMostTopNode interval calendar = do+ guard $ intervalFitsCalendar interval calendar+ result <- rtmNode (getFrom interval, getTo interval) (toZipper calendar)+ listToMaybe result+ where+ rtmNode (lower, upper) zipper@(Unit t _ _, _)+ | upper == getFrom t && getFrom t >= lower = Just [zipper]+ | otherwise = Just []+ rtmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do+ let (from, to) = (getFrom t, getTo t)+ (lChild, bsl) <- goLeft node+ (rChild, bsr) <- goRight node+ if upper == to && from >= lower+ then Just [node]+ else do+ let toL = (getTo . getInterval) lChild+ fromR = (getFrom . getInterval) rChild+ lAnswer <-+ if upper <= toL+ then rtmNode i (lChild, bsl)+ else Just []+ rAnswer <-+ if upper >= fromR+ then rtmNode i (rChild, bsr)+ else Just []+ return $ lAnswer ++ rAnswer++commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper+commonParent zipper1@(node1, bs1) zipper2@(node2, bs2) = do+ let bs1Length = length bs1+ bs2Length = length bs2+ interval1 = getInterval node1+ interval2 = getInterval node2+ case bs1Length `compare` bs2Length of+ LT -> do+ zipper2' <- goUp zipper2+ commonParent zipper1 zipper2'+ EQ ->+ if interval1 == interval2+ then Just zipper1+ else do+ zipper1' <- goUp zipper1+ zipper2' <- goUp zipper2+ commonParent zipper1' zipper2'+ GT -> do+ zipper1' <- goUp zipper1+ commonParent zipper1' zipper2++topMostNodes :: TimePeriod+ -> Calendar+ -> Maybe [CalendarZipper]+topMostNodes interval calendar = do+ rtNode <- rightMostTopNode (toTimeUnit interval) calendar+ let intervalR = getZipInterval rtNode+ if intervalR == interval+ then return [rtNode]+ else do+ ltNode <- leftMostTopNode interval calendar+ let intervalL = getZipInterval ltNode+ parent <- commonParent ltNode rtNode+ answer <- goDownTree (toTimeUnit interval) intervalL intervalR parent+ return $ ltNode : rtNode : answer+ where+ goDownTree period leftMost rightMost zipper@(Unit t _ _, _) =+ if isIncluded t period+ then if t == rightMost || t == leftMost+ then Just []+ else Just [zipper]+ else Just []+ goDownTree period leftMost rightMost node@(Node t _ _ _ _, _) =+ if isIncluded t period+ then if t == rightMost || t == leftMost+ then Just []+ else Just [node]+ else do+ lChild <- goLeft node+ rChild <- goRight node+ lAnswer <- goDownTree period leftMost rightMost lChild+ rAnswer <- goDownTree period leftMost rightMost rChild+ return $ lAnswer ++ rAnswer++updateQ :: CalendarZipper -> Maybe CalendarZipper+updateQ zipper@(node, []) = Just zipper+updateQ zipper = do+ parent <- goUp zipper+ lChild <- goLeft parent+ rChild <- goRight parent+ let (Node period q qn left right, bs) = parent+ lQ = getQ lChild+ rQ = getQ rChild+ updateQ (Node period (unions [lQ, rQ, qn]) qn left right, bs)++goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper+goToNode interval calendar = do+ result <- go (toTimeUnit interval) (toZipper calendar)+ listToMaybe result+ where+ go interval zipper@(Unit t _ _, _)+ | interval == t = Just [zipper]+ | otherwise = Just []+ go interval node@(Node t _ _ _ _, bs) =+ if interval == t+ then Just [node]+ else do+ (lChild, bsl) <- goLeft node+ (rChild, bsr) <- goRight node+ let (lower, upper) = (getFrom interval, getTo interval)+ toL = (getTo . getInterval) lChild+ fromR = (getFrom . getInterval) rChild+ lAnswer <- if lower >= fromR+ then Just []+ else go interval (lChild, bsl)+ rAnswer <- if upper <= toL+ then Just []+ else go interval (rChild, bsr)+ return $ lAnswer ++ rAnswer++updateCalendar :: [TimePeriod]+ -> Set Text+ -> Calendar+ -> (Set Text -> Set Text -> Maybe (Set Text))+ -> Maybe Calendar+updateCalendar [] _ cal _ = Just cal+updateCalendar (interval:ins) elts cal f = do+ updatedRoot <- updateQandQN elts (toTimeUnit interval) cal+ updateCalendar ins elts updatedRoot f+ where+ update s (Unit unit q qn, bs) = do+ newQ <- f q s+ newQN <- f qn s+ let zipper = (Unit unit newQ newQN, bs)+ updateQ zipper+ update s (Node interval q qn left right, bs) = do+ newQ <- f q s+ newQN <- f qn s+ let zipper = (Node interval newQ newQN left right, bs)+ updateQ zipper++ updateQandQN set interval cal = do+ zipper <- goToNode interval cal+ updatedZip <- update set zipper+ (root, _) <- upToRoot updatedZip+ return root++checkQuantAvailability :: TimePeriod+ -> Int+ -> Set Text+ -> CalendarZipper+ -> Bool+checkQuantAvailability interval qt units zipper =+ maybe False (not . null) $ checkAvailability interval qt units zipper+ where+ checkAvailability _ qt units zipper@(Unit {}, _) = do+ qMax <- getQMax zipper+ let avUnits = size (difference units qMax)+ if qt <= avUnits+ then Just [()]+ else Nothing+ checkAvailability interval qt units node@(Node t _ _ _ _, _) = do+ qMax <- getQMax node+ let avUnits = size (difference units qMax)+ guard $ qt <= avUnits || not (isIncluded t interval)+ (lChild, bsl) <- goLeft node+ (rChild, bsr) <- goRight node+ let (lower, upper) = (getFrom interval, getTo interval)+ toL = (getTo . getInterval) lChild+ fromR = (getFrom . getInterval) rChild+ lAnswer <-+ if lower >= fromR+ then Just []+ else checkAvailability interval qt units (lChild, bsl)+ rAnswer <-+ if upper <= toL+ then Just []+ else checkAvailability interval qt units (rChild, bsr)+ return $ lAnswer ++ rAnswer++checkReservAvailability :: Reservation+ -> Set Text+ -> CalendarZipper+ -> Bool+checkReservAvailability reservation units zipper =+ maybe False (not . null) $ checkAvailability reservation units zipper+ where+ checkAvailability reservation units zipper@(Unit {}, _) = do+ qMax <- getQMax zipper+ let avUnits = difference units qMax+ isSubset = isSubsetOf (reservUnits reservation) avUnits+ if isSubset+ then Just [()]+ else Nothing+ checkAvailability reservation units node@(Node t _ _ _ _, _) = do+ qMax <- getQMax node+ let interval = (toTimeUnit . reservPeriod) reservation+ avUnits = difference units qMax+ isSubset = isSubsetOf (reservUnits reservation) avUnits+ guard $ isSubset || not (isIncluded t interval)+ (lChild, bsl) <- goLeft node+ (rChild, bsr) <- goRight node+ let (lower, upper) = (getFrom interval, getTo interval)+ toL = (getTo . getInterval) lChild+ fromR = (getFrom . getInterval) rChild+ lAnswer <-+ if lower >= fromR+ then Just []+ else checkAvailability reservation units (lChild, bsl)+ rAnswer <-+ if upper <= toL+ then Just []+ else checkAvailability reservation units (rChild, bsr)+ return $ lAnswer ++ rAnswer
+ src/Time/SCalendar/Operations.hs view
@@ -0,0 +1,160 @@+module Time.SCalendar.Operations+ ( augmentCalendar+ , isQuantityAvailable+ , isReservAvailable+ , reservePeriod'+ , reservePeriod+ , reserveManyPeriods+ , reserveManyPeriods'+ , cancelPeriod+ , cancelManyPeriods+ , periodReport+ ) where+++import Data.Maybe (isNothing)+import Time.SCalendar.Zippers+import Time.SCalendar.Types+import Data.Time (UTCTime(..), toGregorian)+import Control.Monad (guard)+import Time.SCalendar.Internal+import qualified Data.Set as S ( null+ , size+ , difference+ , isSubsetOf+ , union+ , unions )++-- | Given an SCalendar of size 2^n, this function increases its size k times, that is,+-- 2^(n+k). The new SCalendar is properly updated up to its root so that it will render+-- the same results as the previous one. For example, given an SCalendar `c` of size 2^5=32,+-- 'augmentCalendar c 3' would produce a new SCalendar of size 2^(5+3)=256.+augmentCalendar :: SCalendar -- ^ SCalendar to be augmented.+ -> Int -- ^ Number of times by which the SCalendar will be augmented.+ -> Maybe SCalendar+augmentCalendar _ k+ | k <= 0 = Nothing+augmentCalendar scal k = do+ let interval = getInterval $ calendar scal+ (from, to) = (getFrom interval, getTo interval)+ (UTCTime gregDay _) = from+ (year, month, day) = toGregorian gregDay+ newSize = daysBetween from to * (2^k)+ largerCal <- createCalendar year month day newSize+ (_, bs) <- goToNode interval largerCal+ updatedCal <- updateQ (calendar scal, bs)+ (root, _) <- upToRoot updatedCal+ return $ SCalendar (calUnits scal) root++-- | Given a quantity, this function determines if it is available in a TimePeriod for a+-- specific SCalendar. Thus, it does not take into account the particular resources whose+-- availability wants to be determined: it is only concerned with the availabilty of a quantity+-- in a specific SCalendar.+isQuantityAvailable :: Int -- ^ Quantity of resources.+ -> TimePeriod -- ^ TimePeriod over which we want to determine the availability of+ -- the quantity.+ -> SCalendar -- ^ SCalendar over which we want to determine the availability of+ -- the quantity in a Given TimePeriod.+ -> Bool+isQuantityAvailable quant interval scal+ | S.null (calUnits scal) = False+ | quant <= 0 = False+ | quant > S.size (calUnits scal) = False+ | not $ intervalFitsCalendar interval (calendar scal) = False+ | otherwise = checkQuantAvailability (toTimeUnit interval) quant (calUnits scal) (calendar scal, [])++-- | Given a Reservation, this function determines if it is available in a SCalendar. A+-- Reservation is the product of a set of identifiers which point to reservable resources+-- and a TimePeriod over which those resources are to be reserved. Thus, this function+-- checks if that particular set of resources is available for a TimePeriod in the given SCalendar.+isReservAvailable :: Reservation -> SCalendar -> Bool+isReservAvailable reservation scal+ | S.null (calUnits scal) = False+ | not $ S.isSubsetOf (reservUnits reservation) (calUnits scal) = False+ | not $ intervalFitsCalendar (reservPeriod reservation) (calendar scal) = False+ | otherwise = checkReservAvailability reservation (calUnits scal) (calendar scal, [])++-- | This function introduces a new Reservation in a Calendar. Note that since no availability check+-- is performed before introducing the Reservation, here we use a plain Calendar. Thus this function+-- is useful to introduce Reservations without any constraint, but that's why it must be used carefully+-- since information can be lost due to the usage of the union set-operation to update the Q and QN sets+-- in the Calendar.+reservePeriod' :: Reservation -> Calendar -> Maybe Calendar+reservePeriod' reservation calendar = do+ let interval = (toTimeUnit . reservPeriod) reservation+ tmNodes <- topMostNodes interval calendar+ let tmIntervals = fmap getZipInterval tmNodes+ updateCalendar tmIntervals (reservUnits reservation) calendar (\x y -> Just $ S.union x y)++-- | This function is like reservePeriod' but adds a list of Reservations without any availabilty check.+reserveManyPeriods' :: [Reservation] -> Calendar -> Maybe Calendar+reserveManyPeriods' [] calendar = Just calendar+reserveManyPeriods' (reservation:rs) calendar = do+ updatedCalendar <- addReservation reservation calendar+ reserveManyPeriods' rs updatedCalendar+ where+ addReservation res cal+ | isNothing maybeCalendar = Just cal+ | otherwise = maybeCalendar+ where maybeCalendar = reservePeriod' res cal++-- | This function introduces a new Reservation in a SCalendar applying an availability check. This means+-- that if the reservation conflicts with others already made in the SCalendar, it will no be introduced.+-- Thus this function takes into account the set of reservable identifiers for the SCalendar to calculate+-- the subset of available ones and introduce the Reservation if possible.+reservePeriod :: Reservation -> SCalendar -> Maybe SCalendar+reservePeriod reservation scalendar+ | not $ isReservAvailable reservation scalendar = Nothing+reservePeriod reservation scal = do+ updatedCalendar <- reservePeriod' reservation (calendar scal)+ return $ SCalendar (calUnits scal) updatedCalendar++-- | This function is like reservePeriod but introduces several Reservations at once. It is important to note+-- that if a Reservation in the list conflicts with others already made in the SCalendar, it will be excluded.+-- Thus the order of the Reservations in the list matters, since if one Reservation passes the availability check+-- but the next one does not, then latter will be excluded.+reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar+reserveManyPeriods [] calendar = Just calendar+reserveManyPeriods (reservation:rs) calendar = do+ updatedCalendar <- addReservation reservation calendar+ reserveManyPeriods rs updatedCalendar+ where+ addReservation res uCal+ | isNothing maybeCalendar = Just uCal+ | otherwise = maybeCalendar+ where maybeCalendar = reservePeriod res uCal++-- | This function removes reserved identifiers in a Calendar according to the Set of identifiers and TimePeriod+-- specified in the Cancellation. Thus a Cancellation only affects the nodes whose upper or lower bounds are+-- included in the TimePeriod of the Cancellation.+cancelPeriod :: Cancellation -> Calendar -> Maybe Calendar+cancelPeriod cancellation calendar = do+ tmNodes <- topMostNodes (cancPeriod cancellation) calendar+ let tmIntervals = fmap getZipInterval tmNodes+ updateCalendar tmIntervals (cancUnits cancellation) calendar diff+ where+ diff x y+ | not $ S.isSubsetOf y x = Nothing+ | otherwise = Just (S.difference x y)++-- | This is like cancelPeriod but performs several Cancellations at once.+cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar+cancelManyPeriods [] calendar = Just calendar+cancelManyPeriods (cancellation:cs) calendar = do+ updatedCalendar <- addCancellation cancellation calendar+ cancelManyPeriods cs updatedCalendar+ where+ addCancellation canc cal+ | isNothing maybeCalendar = Just cal+ | otherwise = maybeCalendar+ where maybeCalendar = cancelPeriod canc cal++-- | Given a TimePeriod and a SCalendar, this function returns a Report which summarizes important+-- data about the reserved and available identifiers in that SCalendar.+periodReport :: TimePeriod -> SCalendar -> Maybe Report+periodReport interval scal = do+ guard $ intervalFitsCalendar interval (calendar scal)+ tmNodes <- topMostNodes (toTimeUnit interval) (calendar scal)+ qMaxs <- mapM getQMax tmNodes+ let sQMax = S.unions qMaxs+ return $ Report interval (calUnits scal) sQMax (S.difference (calUnits scal) sQMax)
+ src/Time/SCalendar/Types.hs view
@@ -0,0 +1,215 @@+module Time.SCalendar.Types+ ( TimePeriod(..)+ , Reservation(..)+ , Cancellation(..)+ , SCalendar(..)+ , Calendar(..)+ , Report(..)+ , isIncluded+ , getFrom+ , getTo+ , toTimeUnit+ , makeTimePeriod+ , makeReservation+ , makeCancellation+ , createCalendar+ , createSCalendar+ , oneDay+ , powerOfTwo+ ) where+++import Data.Time ( UTCTime(..)+ , NominalDiffTime+ , addUTCTime+ , fromGregorianValid )+import Data.Text (Text)+import Data.Set (Set)+import qualified Data.Set as S (empty)+++-- | This data type is either a TimeInterval of the form (start-date, end-date)+-- or a TimeUnit which, in this case, is a nominal day. The time unit of this calendar+-- library is a nominal day, that is, 86400 seconds. TimeIntervals as well as+-- TimeUnits are stored as UTCTime so that it is easy to transform results to local+-- time or store results in databases as timestamps.+data TimePeriod =+ TimeInterval UTCTime UTCTime -- ^ TimeIntervals represent the number of days that a node+ -- in a calendar covers from a start-date up to an end-date.+ | TimeUnit UTCTime -- ^ TimeUnits are only encountered in the leaves of a calendar and represent+ -- a specific day of the calendar.+ deriving (Eq, Show)++-- | Check if a time-period `t1` is included in a time-period `t2`. Note that neither a+-- TimeUnit can be included in another TimeUnit nor a TimeInterval can be included+-- in a TimeUnit. If two TimeIntervals are equal they are said to be included in+-- one another.+isIncluded :: TimePeriod -> TimePeriod -> Bool+isIncluded (TimeUnit _) (TimeUnit _) = False+isIncluded (TimeUnit t) (TimeInterval from to) = from <= t && t <= to+isIncluded (TimeInterval _ _) (TimeUnit _) = False+isIncluded (TimeInterval ifrom ito) (TimeInterval ofrom oto)+ = and [ ofrom <= ifrom, ifrom <= oto, ofrom <= ito, ito <= oto, ifrom <= ito ]++-- | Getter function to get the UTCTime start-date from a TimePeriod. For a TimeUnit+-- the start-sate and the end-date are equal.+getFrom :: TimePeriod -> UTCTime+getFrom (TimeUnit t) = t+getFrom (TimeInterval from _) = from++-- | Getter function to fet the UTCTime end-date from a TimePeriod. Again, for a TimeUnit+-- the start-sate and the end-date are equal.+getTo :: TimePeriod -> UTCTime+getTo (TimeUnit t) = t+getTo (TimeInterval _ to) = to++-- | This function transforms a TimeInterval into a TimeUnit in case that the start-date and+-- end-date of that TimeInterval are equal.+toTimeUnit :: TimePeriod -> TimePeriod+toTimeUnit i@(TimeUnit _) = i+toTimeUnit i@(TimeInterval t1 t2)+ | t1 == t2 = TimeUnit t1+ | otherwise = i++-- | A Reservation is the product of a set of identifiers and a TimePeriod over which the+-- resources identified by the set will be reserved.+data Reservation = Reservation+ { reservUnits :: Set Text -- ^ Set of identifiers which point to reservable resources.+ , reservPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be reserved.+ } deriving (Eq, Show)++-- | A Cancellation is the product of a set of identifiers which point to resources previously+-- reserved in a Calendar and a TimePeriod over which those resources were reserved.+data Cancellation = Cancellation+ { cancUnits :: Set Text -- ^ Set of identifiers which point to resources to be cancelled.+ , cancPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be cancelled.+ } deriving (Eq, Show)++-- | A Report represents a summary of important facts related to an SCalendar.+data Report = Report+ { reportPeriod :: TimePeriod -- ^ The TimePeriod which the report covers.+ , totalUnits :: Set Text -- ^ The set of total identifiers reservable in the SCalendar this Report belongs to.+ , reservedUnits :: Set Text -- ^ The set of total identifiers which have been reserved in a TimePeriod in+ -- the SCalendar related to this Report.+ , remainingUnits :: Set Text -- ^ The set of total identifiers which are still available in a Time<Period in the+ -- SCalendar related to this Report.+ } deriving (Eq, Show)++-- | A Calendar is a recursive tree-structure whose nodes are TimePeriods representing the interval+-- of time covered by them. TimeUnits are only encountered in the leaves since they represent+-- specific days, or time units, of the Calendar. The unit of time of this Calendar library is a nominal+-- day (or 86400 seconds). Each node of a Calendar also carries additional data according to the+-- "top-nodes" algorithm: a `Q` set and a `QN` set. For more information about the meaning of these+-- sets visit: <https://en.wikipedia.org/wiki/Top-nodes_algorithm>+data Calendar =+ Unit TimePeriod (Set Text) (Set Text)+ | Node TimePeriod (Set Text) (Set Text) Calendar Calendar+ deriving (Eq, Show)++-- | An SCalendar is the product of a set of identifiers, which point to a set of available resources,+-- and a Calendar.+data SCalendar = SCalendar+ { calUnits :: Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by+ -- the root node of the Calendar.+ , calendar :: Calendar -- ^ Calendar which covers the complete period of time over which a set of+ -- resources can be reserved.+ } deriving (Eq, Show)+++-- | Given a year, a month and a day this function creates a time period which covers the specified+-- number of days.+makeTimePeriod :: Integer -- ^ Year.+ -> Int -- ^ Month.+ -> Int -- ^ Day.+ -> Int -- ^ Number of days covered by TimePeriod.+ -> Maybe TimePeriod+makeTimePeriod _ _ _ numDays+ | numDays < 0 = Nothing+makeTimePeriod year month day numDays = do+ gregDay <- fromGregorianValid year month day+ let from = UTCTime gregDay 0+ to = (fromIntegral numDays * oneDay) `addUTCTime` from+ return $ if numDays == 0+ then TimeUnit from+ else TimeInterval from to++-- | Given a TimePeriod and a set of identifiers this function creates a reservation.+makeReservation :: TimePeriod -- ^ TimePeriod which the rerservation will cover.+ -> Set Text -- ^ Set of identifiers which point to the resources to be reserved from an SCalendar.+ -> Maybe Reservation+makeReservation period units+ | null units = Nothing+ | not $ isValidInterval period' = Nothing+ | otherwise = Just $ Reservation units period'+ where+ period' = toTimeUnit period++-- | Given a TimePeriod and a set of identifiers this function creates a cancellation.+makeCancellation :: TimePeriod -- ^ TimePeriod which the cancellation will cover.+ -> Set Text -- ^ Set of identifiers which point to the resources to be cancelled from an SCalendar.+ -> Maybe Cancellation+makeCancellation period units+ | null units = Nothing+ | not $ isValidInterval period' = Nothing+ | otherwise = Just $ Cancellation units period'+ where+ period' = toTimeUnit period++-- | Given a year, a month, and a day this function creates a Calendar which covers the specified+-- number of days. The TimePeriod in the root node of a Calendar does not exactly span the+-- number of days specified in the function, but a number of days which is a power of 2 and+-- which is greater than or equal to the number of days specified.+createCalendar :: Integer -- ^ Year.+ -> Int -- ^ Month.+ -> Int -- ^ Day.+ -> Int -- ^ Number of days covered by the Calendar.+ -> Maybe Calendar+createCalendar year month day numDays+ | numDays <= 1 = Nothing+ | otherwise = do+ gregDay <- fromGregorianValid year month day+ let fstDay = UTCTime gregDay 0+ return $ go fstDay power+ where+ power = powerOfTwo numDays+ go from factor+ | parentDist == 0 = Unit (TimeUnit from) S.empty S.empty+ | otherwise =+ Node (TimeInterval from ((oneDay * parentDist) `addUTCTime` from))+ S.empty+ S.empty+ (go from (factor - 1))+ (go ((oneDay * childDist) `addUTCTime` from) (factor - 1))+ where+ parentDist = (2^factor) - 1+ childDist = 2^(factor - 1)++-- | This constructor additionally attaches a set of identifiers, which point to the available resources of the+-- calendar. Thus, this function creates an SCalendar which is basically a Calendar with a set of resources which+-- can be reserved over the period of time determined by the root node of the Calendar.+createSCalendar :: Integer -- ^ Year.+ -> Int -- ^ Month.+ -> Int -- ^ Day.+ -> Int -- ^ Number of days covered by the Calendar.+ -> Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by+ -- the root node of the Calendar.+ -> Maybe SCalendar+createSCalendar _ _ _ _ tUnits+ | null tUnits = Nothing+createSCalendar year month day numDays tUnits = do+ calendar <- createCalendar year month day numDays+ return $ SCalendar tUnits calendar+++-- HELPER FUNCTIONS+isValidInterval :: TimePeriod -> Bool+isValidInterval (TimeUnit _) = True+isValidInterval (TimeInterval from to) = from < to++powerOfTwo :: Int -> Int+powerOfTwo n =+ let power = ceiling $ logBase 2 (fromIntegral $ abs n)+ in if power > 1 then power else 2++oneDay :: NominalDiffTime+oneDay = 86400
+ src/Time/SCalendar/Zippers.hs view
@@ -0,0 +1,52 @@+module Time.SCalendar.Zippers+ ( CalendarZipper+ , goUp+ , goLeft+ , goRight+ , upToRoot+ , toZipper+ ) where+++import Data.Set (Set)+import Data.Text (Text)+import Time.SCalendar.Types (Calendar(..), TimePeriod)+++data Crumb = LeftCrumb TimePeriod (Set Text) (Set Text) Calendar+ | RightCrumb TimePeriod (Set Text) (Set Text) Calendar+ deriving Eq++instance Show Crumb where+ show LeftCrumb{} = "LeftCrumb"+ show RightCrumb{} = "RightCrumb"++type Breadcrumbs = [Crumb]+type CalendarZipper = (Calendar, Breadcrumbs)+++goLeft :: CalendarZipper -> Maybe CalendarZipper+goLeft (Node interval q qn left right, bs) =+ Just (left, LeftCrumb interval q qn right : bs)+goLeft (Unit{}, _) = Nothing++goRight :: CalendarZipper -> Maybe CalendarZipper+goRight (Node interval q qn left right, bs) =+ Just (right, RightCrumb interval q qn left : bs)+goRight (Unit{}, _) = Nothing++goUp :: CalendarZipper -> Maybe CalendarZipper+goUp (calendar, LeftCrumb interval q qn right : bs)+ = Just (Node interval q qn calendar right, bs)+goUp (calendar, RightCrumb interval q qn left : bs)+ = Just (Node interval q qn left calendar, bs)+goUp (_, []) = Nothing++upToRoot :: CalendarZipper -> Maybe CalendarZipper+upToRoot (node, []) = Just (node, [])+upToRoot zipper = do+ parent <- goUp zipper+ upToRoot parent++toZipper :: Calendar -> CalendarZipper+toZipper calendar = (calendar, [])
+ test/SCalendarTest/Arbitrary.hs view
@@ -0,0 +1,123 @@+module SCalendarTest.Arbitrary where+++import Test.QuickCheck.Arbitrary+import SCalendarTest.Helpers (testIdentifiers, startDay)+import Control.Monad (replicateM, guard)+import Data.Set (Set)+import Data.Maybe (fromMaybe, fromJust)+import Data.Text (Text)+import qualified Data.Set as S (fromList)+import Time.SCalendar.Types ( Calendar(..)+ , Reservation+ , TimePeriod+ , createCalendar+ , makeTimePeriod+ , makeReservation+ , getFrom+ , getTo )+import Time.SCalendar.Zippers ( CalendarZipper+ , goRight+ , goLeft )+import Time.SCalendar.Internal ( getZipInterval+ , getInterval+ , daysBetween+ , intervalFitsCalendar )+import Test.QuickCheck.Gen (choose, sized, vectorOf)+++-- | Convinient type for Intervals which fit a Calendar+data CalendarReservations = CalReservs Calendar [Reservation]++newtype Identifier = Identifier Text+ deriving (Eq, Ord)++newtype Identifiers = Identifiers (Set Identifier)++data RandomZippers = RandomZippers CalendarZipper CalendarZipper+++-- | Arbitrary-size calendars+instance Arbitrary Calendar where+ arbitrary = do+ let (year, month, day) = startDay+ -- ^ Random size calendars up to 512 days+ -- and starting from 1970+ size <- choose (2, 9)+ return $ fromJust $ createCalendar year month day size++-- | Arbitrary instance for time Intervals+instance Arbitrary TimePeriod where+ arbitrary = do+ numDays <- choose (1, 27)+ return $ fromJust $ makeTimePeriod 1970 1 1 numDays+-- | --+++-- | Arbitrary instance for a single Identifier+instance Arbitrary Identifier where+ arbitrary = do+ i <- choose (0, 99)+ return $ Identifier $ testIdentifiers !! i++instance Show Identifier where+ show (Identifier i) = show i+-- | --+++-- | Arbitrary instance for CalendarReservations+instance Arbitrary CalendarReservations where+ arbitrary = do+ calendar <- arbitrary+ n <- choose (1, 50)+ reservs <- replicateM n $ getSuitableInterval calendar+ return $ CalReservs calendar reservs+ where+ buildReserv interval = sized $ \n -> do+ k <- choose (1, abs $ n + 1)+ identifiers <- vectorOf k arbitrary+ return $ fromJust $ makeReservation interval (S.fromList $ (\(Identifier t) -> t) <$> identifiers)+ -- ^ --+ getSuitableInterval cal = do+ interval <- arbitrary+ maybe (getSuitableInterval cal)+ (const $ buildReserv interval)+ (guard $ intervalFitsCalendar interval cal)++instance Show CalendarReservations where+ show (CalReservs calendar reservs) =+ "Calendar root: " ++ show (getInterval calendar) +++ " , " +++ "Reservations: " ++ show reservs+-- | --+++-- | Arbitrary pair of Zippers belonging to the same calendar+instance Arbitrary RandomZippers where+ arbitrary = do+ calendar <- arbitrary+ let depth = getDepth calendar+ zip1Depth <- choose (0, depth)+ zip2Depth <- choose (0, depth)+ let root = (calendar, [])+ maybeZippers = do+ zip1 <- goDown (Just root) zip1Depth+ zip2 <- goDown (Just root) zip2Depth+ return $ RandomZippers zip1 zip2+ return $ fromMaybe (RandomZippers root root) maybeZippers+ where+ getDepth :: Calendar -> Int+ getDepth cal = round $+ let interval = getInterval cal+ in logBase 2 (fromIntegral $ daysBetween (getFrom interval) (getTo interval))+ -- ^ --+ pickBranch zipper n+ | n `mod` 2 == 0 = goRight zipper+ | otherwise = goLeft zipper+ -- ^ --+ goDown maybeZipper 0 = maybeZipper+ goDown maybeZipper i =+ maybeZipper >>= (\zipper -> goDown (pickBranch zipper i) (i-1))++instance Show RandomZippers where+ show (RandomZippers zip1 zip2) = show (getZipInterval zip1, getZipInterval zip2)
+ test/SCalendarTest/Constructors.hs view
@@ -0,0 +1,34 @@+module SCalendarTest.Constructors where+++import Time.SCalendar.Operations (augmentCalendar)+import SCalendarTest.Helpers (startDay)+import Data.Maybe (fromMaybe)+import Time.SCalendar.Internal ( daysBetween+ , getInterval )+import Time.SCalendar.Types ( SCalendar(..)+ , powerOfTwo+ , createCalendar+ , getFrom+ , getTo )+import qualified Data.Set as S (empty)+++calendarSizePowerOfTwo :: Int -> Bool+calendarSizePowerOfTwo n = fromMaybe False $ do+ let (year, month, day) = startDay+ size = if n > 1 then n else abs n + 2+ calendar <- createCalendar year month day size+ let i = getInterval calendar+ return $ daysBetween (getFrom i) (getTo i) == 2 ^ powerOfTwo size++augmentedCalendarPowerOfKPlusN :: Int -> Int -> Bool+augmentedCalendarPowerOfKPlusN n k = fromMaybe False $ do+ let (year, month, day) = startDay+ n' = powerOfTwo n+ k' = powerOfTwo k+ calendar <- createCalendar year month day n'+ (SCalendar _ calendar') <- augmentCalendar (SCalendar S.empty calendar) k'+ let i = getInterval calendar+ j = getInterval calendar'+ return $ daysBetween (getFrom j) (getTo j) == daysBetween (getFrom i) (getTo i) * (2 ^ k')
+ test/SCalendarTest/Helpers.hs view
@@ -0,0 +1,23 @@+module SCalendarTest.Helpers+ ( getUTCdayNum+ , testIdentifiers+ , startDay+ ) where+++import Data.Time.Clock (UTCTime (..))+import Data.Time.Calendar (toGregorian)+import Data.Text (Text)+import qualified Data.Text as T (pack)+++testIdentifiers :: [Text]+testIdentifiers = T.pack <$> (show <$> [1.. 100])++getUTCdayNum :: UTCTime -> Int+getUTCdayNum (UTCTime day _) =+ let (_, _, num) = toGregorian day+ in num++startDay :: (Integer, Int, Int)+startDay = (1970, 1, 1)
+ test/SCalendarTest/Internal.hs view
@@ -0,0 +1,138 @@+module SCalendarTest.Internal where+++import Data.List (elem)+import Data.Maybe (isJust, fromMaybe)+import Data.Time (UTCTime(..), toGregorian, diffUTCTime )+import SCalendarTest.Helpers (getUTCdayNum)+import Time.SCalendar.Types ( Calendar(..)+ , Reservation(..)+ , TimePeriod+ , getFrom+ , getTo+ , isIncluded+ , powerOfTwo+ , oneDay+ , makeTimePeriod )+import Time.SCalendar.Zippers (goUp)+import SCalendarTest.Arbitrary (RandomZippers(..), CalendarReservations(..))+import Time.SCalendar.Internal ( goToNode+ , leftMostTopNode+ , rightMostTopNode+ , topMostNodes+ , getZipInterval+ , commonParent )+++alwaysGreateOrEqualThanN :: Int -> Bool+alwaysGreateOrEqualThanN n = 2^ powerOfTwo n >= n++eqIntervalsIfIncludeEachOther :: TimePeriod -> TimePeriod -> Bool+eqIntervalsIfIncludeEachOther i j+ | isIncluded i j && isIncluded j i = i1 == j1 && i2 == j2+ | isIncluded i j = not $ isIncluded j i+ | isIncluded j i = not $ isIncluded i j+ | not (isIncluded i j) && not (isIncluded j i) && wellFormed = i1 < j2 || j1 < i2+ | otherwise = not wellFormed+ where+ (i1, i2) = (getFrom i, getTo i)+ (j1, j2) = (getFrom j, getTo j)+ wellFormed = i1 <= i2 && j1 <= j2++returnsTargetZipper :: Calendar -> TimePeriod -> Bool+returnsTargetZipper calendar interval =+ let maybeCalendar = fst <$> goToNode interval calendar+ in maybe (ifNothing calendar) checkTarget maybeCalendar+ where+ checkTarget (Unit unit _ _) = unit == interval+ checkTarget (Node interval' _ _ _ _) = interval' == interval+ -- ^ --+ ifNothing (Node interval' _ _ _ _) =+ not $ isIncluded interval interval' && ((getUTCdayNum . getFrom) interval) `mod` 2 == 0+ ifNothing _ = False++isLeftMostTopNode :: CalendarReservations -> Bool+isLeftMostTopNode (CalReservs _ []) = False+isLeftMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ i2 <- getZipInterval <$> leftMostTopNode i1 calendar+ return $ getFrom i2 == getFrom i1 &&+ if getTo i2 == getTo i1+ then (getFrom i1, getTo i1) == (getFrom i2, getTo i2)+ else getTo i2 < getTo i1+ where+ i1 = reservPeriod reserv++isRightMostTopNode :: CalendarReservations -> Bool+isRightMostTopNode (CalReservs _ []) = False+isRightMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ i2 <- getZipInterval <$> rightMostTopNode i1 calendar+ return $ getTo i2 == getTo i1 &&+ if getFrom i2 == getFrom i1+ then (getFrom i1, getTo i1) == (getFrom i2, getTo i2)+ else getFrom i2 > getFrom i1+ where+ i1 = reservPeriod reserv++returnsCommonParent :: RandomZippers -> Bool+returnsCommonParent (RandomZippers zip1 zip2) = fromMaybe False $ do+ parent <- commonParent zip1 zip2+ let c1 = getZipInterval zip1+ c2 = getZipInterval zip2+ p= getZipInterval parent+ return $ getFrom p <= getFrom c1 &&+ getFrom p <= getFrom c2 &&+ getTo p >= getTo c1 &&+ getTo p >= getTo c2++leftMostAndRightMostInTopMost :: CalendarReservations -> Bool+leftMostAndRightMostInTopMost (CalReservs _ []) = False+leftMostAndRightMostInTopMost (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ ltmInterval <- getZipInterval <$> leftMostTopNode interval calendar+ rtmInterval <- getZipInterval <$> rightMostTopNode interval calendar+ topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar)+ return $ (ltmInterval `elem` topMostIntervals) && (rtmInterval `elem` topMostIntervals)+ where+ interval = reservPeriod reserv++outerMostNodesIncludeIntermediate :: CalendarReservations -> Bool+outerMostNodesIncludeIntermediate (CalReservs _ []) = False+outerMostNodesIncludeIntermediate (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar+ to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar+ topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar)+ -- ^ Each intermediate interval must be included in the leftmost and rightmost ones+ let numDays = round $ diffUTCTime to' from' / oneDay+ (UTCTime gregDay _) = from'+ (year, month, day) = toGregorian gregDay+ timePeriod <- makeTimePeriod year month day numDays+ return $ all (`isIncluded` timePeriod) topMostIntervals || timePeriod `elem` topMostIntervals+ where+ interval = reservPeriod reserv++ifOnlyOneTopNodeItEqualsInterval :: CalendarReservations -> Bool+ifOnlyOneTopNodeItEqualsInterval (CalReservs _ []) = False+ifOnlyOneTopNodeItEqualsInterval (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar)+ if length topMostIntervals == 1+ then return $ head topMostIntervals == interval+ else return True+ where+ interval = reservPeriod reserv++parentOfTopNodesNotIncluded :: CalendarReservations -> Bool+parentOfTopNodesNotIncluded (CalReservs _ []) = False+parentOfTopNodesNotIncluded (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar+ to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar+ tmNodes <- topMostNodes interval calendar+ parentIntervals <- (fmap . fmap) getZipInterval+ (sequence $ filter isJust (goUp <$> tmNodes))+ let numDays = round $ diffUTCTime to' from' / oneDay+ (UTCTime gregDay _) = from'+ (year, month, day) = toGregorian gregDay+ timePeriod <- makeTimePeriod year month day numDays+ return $ all (`notIncluded` timePeriod) parentIntervals+ where+ notIncluded i1 i2 = not $ isIncluded i1 i2+ -- ^ --+ interval = reservPeriod reserv
+ test/SCalendarTest/Operations.hs view
@@ -0,0 +1,88 @@+module SCalendarTest.Operations where+++import Time.SCalendar.Operations ( reserveManyPeriods+ , reservePeriod'+ , cancelManyPeriods+ , isQuantityAvailable,+ isReservAvailable )+import SCalendarTest.Helpers (getUTCdayNum, testIdentifiers)+import SCalendarTest.Arbitrary (CalendarReservations(..))+import Data.Maybe (isJust, fromMaybe)+import Time.SCalendar.Internal ( goToNode+ , getQMax+ , getZipInterval )+import Time.SCalendar.Zippers (goLeft, goRight, goUp)+import Time.SCalendar.Types ( Calendar(..)+ , SCalendar(..)+ , Reservation(..)+ , getFrom+ , getTo+ , makeCancellation )+import qualified Data.Set as S (isSubsetOf, fromList, size)+++symmetricalIntervalLength :: Calendar -> Bool+symmetricalIntervalLength calendar =+ fromMaybe False (checkSimmetry calZipper)+ where+ calZipper = (calendar, [])+ -- ^ --+ checkSimmetry (Unit{}, _) = Just True+ checkSimmetry zipper = do+ leftChild <- goLeft zipper+ rightChild <- goRight zipper+ let i1 = getZipInterval leftChild+ i2 = getZipInterval rightChild+ intervalSymmetry = getUTCdayNum (getTo i1) - getUTCdayNum (getFrom i1)+ == getUTCdayNum (getTo i2) - getUTCdayNum (getFrom i2)+ return $ intervalSymmetry &&+ fromMaybe False (checkSimmetry leftChild) &&+ fromMaybe False (checkSimmetry rightChild)++qMaxOfParentIncludedInChildren :: CalendarReservations -> Bool+qMaxOfParentIncludedInChildren (CalReservs calendar reservs) = fromMaybe False $ do+ (SCalendar _ calendar') <- reserveManyPeriods reservs (SCalendar (S.fromList testIdentifiers) calendar)+ checks <- sequence $ filter isJust (checkQmax calendar' . reservPeriod <$> reservs)+ return $ and checks+ where+ checkQmax cal interval = do+ zipper <- goToNode interval cal+ zipParent <- goUp zipper+ zipLChild <- goLeft zipper+ qMax <- getQMax zipper+ qMaxParent <- getQMax zipParent+ qMaxLChild <- getQMax zipLChild+ return $ qMaxParent `S.isSubsetOf` qMax &&+ qMax `S.isSubsetOf` qMaxLChild++quantityNotAvailableAfterReservation :: CalendarReservations -> Bool+quantityNotAvailableAfterReservation (CalReservs _ []) = False+quantityNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ calendar' <- reservePeriod' reserv calendar+ return $ not $+ isQuantityAvailable (totalUnits - S.size (reservUnits reserv) + 1)+ (reservPeriod reserv)+ (SCalendar (S.fromList testIdentifiers) calendar')+ where+ totalUnits = length testIdentifiers++periodNotAvailableAfterReservation :: CalendarReservations -> Bool+periodNotAvailableAfterReservation (CalReservs _ []) = False+periodNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do+ calendar' <- reservePeriod' reserv calendar+ return $ not $+ isReservAvailable reserv (SCalendar (S.fromList testIdentifiers) calendar') &&+ S.size (reservUnits reserv) > 0++reservAvailableAfterCancellation :: CalendarReservations -> Bool+reservAvailableAfterCancellation (CalReservs _ []) = False+reservAvailableAfterCancellation (CalReservs calendar reservs) = fromMaybe False $ do+ (SCalendar _ calendar') <- reserveManyPeriods reservs+ (SCalendar (S.fromList testIdentifiers) calendar)+ cancellations <- mapM reservToCanc reservs+ calendar'' <- cancelManyPeriods cancellations calendar'+ return $ and $+ flip isReservAvailable (SCalendar (S.fromList testIdentifiers) calendar'') <$> reservs+ where+ reservToCanc reserv = makeCancellation (reservPeriod reserv) (reservUnits reserv)
+ test/Test.hs view
@@ -0,0 +1,76 @@+module Main where+++import Test.Hspec+import Test.QuickCheck.Property (property)+import SCalendarTest.Internal ( alwaysGreateOrEqualThanN+ , eqIntervalsIfIncludeEachOther+ , returnsTargetZipper+ , isLeftMostTopNode+ , isRightMostTopNode+ , returnsCommonParent+ , leftMostAndRightMostInTopMost+ , outerMostNodesIncludeIntermediate+ , ifOnlyOneTopNodeItEqualsInterval+ , parentOfTopNodesNotIncluded )+import SCalendarTest.Operations ( symmetricalIntervalLength+ , qMaxOfParentIncludedInChildren+ , quantityNotAvailableAfterReservation+ , periodNotAvailableAfterReservation+ , reservAvailableAfterCancellation )+import SCalendarTest.Constructors (calendarSizePowerOfTwo, augmentedCalendarPowerOfKPlusN)+++main :: IO ()+main =+ hspec $ do+ describe "powerOftwo :: Int -> Int" $ do+ it "always returns a power of 2 greater or equal than its argument" $ do+ property alwaysGreateOrEqualThanN+ describe "isIncluded :: isIncluded :: TimePeriod -> TimePeriod -> Bool" $ do+ it "determines if the first interval is included in the second one" $ do+ property eqIntervalsIfIncludeEachOther+ describe "createCalendar :: createCalendar :: FirstDay -> NumDays -> Maybe Calendar" $ do+ it "creates a calendar with a number of days 2^(powerOftwo NumDays)" $ do+ property calendarSizePowerOfTwo+ it "creates a calendar with symmetric intervals" $ do+ property symmetricalIntervalLength+ describe "augmentCalendar :: SCalendar -> Int -> Maybe SCalendar" $ do+ it "always creates a calendar augmented k times the power of the original size" $ do+ property augmentedCalendarPowerOfKPlusN+ describe "goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do+ it "goes to the node with interval (From, To) in the calendar" $ do+ property returnsTargetZipper+ describe "leftMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do+ it "returns a Zipper with a valid left-most interval" $ do+ property isLeftMostTopNode+ describe "rightMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do+ it "returns a Zipper with a valid right-most interval" $ do+ property isRightMostTopNode+ describe "commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper" $ do+ it "returns a Zipper which is a common parent node of its arguments" $ do+ property returnsCommonParent+ describe "topMostNodes :: TimePeriod -> Calendar -> Maybe [CalendarZipper]" $ do+ it "returns a list of topmost-nodes *including* the rightmost and the leftmost ones" $ do+ property leftMostAndRightMostInTopMost+ it "returns a list of topmost-nodes *included* in the rightmost and the leftmost ones" $ do+ property outerMostNodesIncludeIntermediate+ it "returns a list of topmost-nodes with no parent included in (From, To)" $ do+ property parentOfTopNodesNotIncluded+ context "when there is only one topmost-node" $ do+ it "must return an interval equal to (From, To)" $ do+ property ifOnlyOneTopNodeItEqualsInterval+ describe "reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar" $ do+ it "returns a Calendar which satisfies that QMax of parent node is included in QMax of left child" $ do+ property qMaxOfParentIncludedInChildren+ describe "isQuantityAvailable :: Quantity -> TimePeriod -> SCalendar -> Bool" $ do+ it "determines if a quantity is available after a reservation" $ do+ property quantityNotAvailableAfterReservation+ describe "isReservAvailable :: Reservation -> SCalendar -> Bool" $ do+ context "when a node has already been reserved" $ do+ it "returns false for the same reservation in that node" $ do+ property periodNotAvailableAfterReservation+ describe "cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar" $ do+ context "when a reservation in a node is cancelled" $ do+ it "becomes again availabale" $ do+ property reservAvailableAfterCancellation