hora-2.2.0: src/Data/Time/Hora/Internal/DatePartSmall.hs
module Data.Time.Hora.Internal.DatePartSmall where
import Data.Binary
import Data.Time.Hora.Internal.Span
import GHC.Generics
import Prelude hiding (negate)
{- | 'DatePartSmall' uses fixed-size storage. Storage (as encoded with "Data.Binary".encode) varies with the constructor used, is noted as \".. bytes\" against each constructor.
allows to operate with dates only ..
.. or time (minute / millisecond precision) only
is convenient for dealing with intervals / timespans
day count begins at 1 Jan 0001: 1 Jan 0001 is day 1
max date is: 11759222-01-19. That's 19 Jan 11759222
see "Data.Time.Hora.Part" for conversion between 'UTCTime' and 'DatePartSmall'
only values constructed with 'DatePartSmall' can be converted to 'UTCTime'
-}
data DatePartSmall = Day Word32 {- ^ days after 31 Dec 1 BC: 1 Jan AD 1 is day 1. See https://en.wikipedia.org/wiki/Anno_Domini
5 bytes -}
| Min Word16 {- ^ minutes (includes hours)
3 bytes
-}
| Ms Word32 {- ^ milliseconds (includes seconds)
5 bytes
-}
| Time Word16 Word32 {- ^ minutes, milliseconds
7 bytes
-}
| DatePartSmall Word32 Word16 Word32 {- ^ date, minutes, milliseconds
11 bytes
-}
| Day' Word32 {- ^ date span in days
5 bytes
-}
| Min' Word16 {- ^ time span in minutes
3 bytes
-}
| Ms' Word32 {- ^ time span in milliseconds
5 bytes
-}
| Neg DatePartSmall -- ^ negate. Hidden constructor
| Error ErrorDetail -- ^ result of failed operation
deriving (Eq, Show, Generic)
{- | substitutes constructor:
'Day' -> 'Day''
'Min' -> 'Min''
'Ms' -> 'Ms''
-}
toSpan::DatePartSmall -> DatePartSmall
toSpan dp0 = case dp0 of
Day d1 -> Day' d1
Min m1 -> Min' m1
Ms ms1 -> Ms' ms1
otherwise -> dp0
{- | adds hidden Neg constructor to 'Day'', 'Min'' or 'Ms''
to enable negative spans -}
negate::DatePartSmall -> DatePartSmall
negate dp0 = case dp0 of
Neg dp1 -> dp1
Day' d1 -> Neg dp0
Min' m1 -> Neg dp0
Ms' ms1 -> Neg dp0
otherwise -> dp0
-- | checks if 'DatePartSmall' is a negative span
isNegative::DatePartSmall -> Bool
isNegative dp0 = case dp0 of
(Neg _) -> True
otherwise -> False
data ErrorDetail = Invalid -- ^ operation is not possible with these constructors
| Overflow -- ^ data type maxed out
| Invalid_Overflow -- ^ 'Invalid' <> 'Overflow'
deriving (Eq, Show, Generic)
instance Binary ErrorDetail
instance Binary DatePartSmall
instance Semigroup DatePartSmall where
-- combine / merge
(<>) (Day d0) (Time m0 ms0) = DatePartSmall d0 m0 ms0 -- 1
(<>) (Min m0) (Ms ms0) = Time m0 ms0 -- 2
-- increment
(<>) d1@(DatePartSmall _ _ _) d2@(Day' _) = incrDecr (+) d1 d2 -- 3
(<>) d1@(DatePartSmall d0 m0 ms0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 4
(<>) d1@(DatePartSmall d0 m0 ms0) d2@(Ms' ms1) = incrDecr (+) d1 d2 -- 5
(<>) d1@(Time m0 ms0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 6
(<>) d1@(Time m0 ms0) d2@(Ms' ms1) = incrDecr (+) d1 d2 -- 7
(<>) d1@(Day m0) d2@(Day' m1) = incrDecr (+) d1 d2 -- 8
(<>) d1@(Min m0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 9
(<>) d1@(Ms m0) d2@(Ms' m1) = incrDecr (+) d1 d2 -- 10
(<>) d1@(Day' m0) d2@(Day' m1) = incrDecr (+) d1 d2 -- 8
(<>) d1@(Min' m0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 9
(<>) d1@(Ms' m0) d2@(Ms' m1) = incrDecr (+) d1 d2 -- 10
-- decrement
(<>) (Neg d1) (Neg d2) = negate $ incrDecr (+) d1 d2
(<>) d1 (Neg d2) = incrDecr (-) d1 d2
-- overwrite
(<>) (DatePartSmall _ _ _) (DatePartSmall d1 m1 ms1) = DatePartSmall d1 m1 ms1 -- 11
(<>) (Time _ _) (Time m1 ms1) = Time m1 ms1 -- 12
(<>) (Day _) (Day d1) = Day d1 -- 13
(<>) (Min _) (Min m1) = Min m1 -- 14
(<>) (Ms _) (Ms ms1) = Ms ms1 -- 15
-- update
(<>) (DatePartSmall d0 _ _) (Time m1 ms1) = DatePartSmall d0 m1 ms1 -- 16
(<>) (Time _ ms0) (Min m1) = Time m1 ms0 -- 17
(<>) (Time m0 _) (Ms ms1) = Time m0 ms1 -- 18
-- errors
(<>) (Error Invalid) (Error Invalid) = Error Invalid -- 19
(<>) (Error Invalid) (Error Overflow) = Error Invalid_Overflow -- 20
(<>) (Error Overflow) (Error Overflow) = Error Overflow -- 21
(<>) (Error Overflow) (Error Invalid) = Error Invalid_Overflow -- 22
(<>) (Error Invalid_Overflow) _ = Error Invalid_Overflow -- 23
(<>) _ (Error Invalid_Overflow) = Error Invalid_Overflow -- 24
(<>) e0@(Error _) _ = e0 -- 25
(<>) _ e0@(Error _) = e0 -- 26
(<>) _ _ = Error Invalid -- 27
{- ^ '<>' can be used both to combine parts (e.g. 'Day', 'Time') and
to add date/time span to the existing parts
combining parts:
'Day' <> 'Time' -> 'DatePartSmall'
>>> show' (mkDay 2018 08 20 <> mkMin 10 2 <> mkMs 30 9)
2018-08-20 10:02:30.009
'Min' <> 'Ms' -> 'Time'
adding span:
'Day' <> 'Day'' -> 'Day'
>>> show' (mkDay 2018 1 1 <> Day' 20)
2018-01-21
>>> show' (mkDay 2018 1 1 <> Day' 180)
2018-06-30
'Min' <> 'Min'' -> 'Min'
>>> show' (mkMin 3 15 <> Min' 200)
06:35
'Ms' <> 'Ms'' -> 'Ms'
>>> show' $ normalize $ mkMin 14 59 <> mkMs 132 9 <> Ms' 5308
15:01:17.317
when incrementing and decrementing, overflow is checked on both upper (max for Word16, Word32) and lower (0) bounds
when incrementing, it is possible to normalize time by recalculating minutes from seconds, days from minutes. See 'normalize' in "Data.Time.Hora.Part"
when decrementing, normalization is not yet implemented. todo
-}
incrDecr::(Int -> Int -> Int) -- ^ op (+) (-)
-> DatePartSmall
-> DatePartSmall
-> DatePartSmall
incrDecr op0 dp1 dp2
| (DatePartSmall d0 m0 ms0) <- dp1,
(Day' d1) <- dp2
= checkOverflow
(\d2 -> DatePartSmall d2 m0 ms0) d0 op0 d1 -- 3
| (DatePartSmall d0 m0 ms0) <- dp1,
(Min' m1) <- dp2
= checkOverflow
(\m2 -> DatePartSmall d0 m2 ms0) m0 op0 m1 -- 4
| (DatePartSmall d0 m0 ms0) <- dp1,
(Ms' ms1) <- dp2
= checkOverflow
(DatePartSmall d0 m0) ms0 op0 ms1 -- 5
| (Time m0 ms0) <- dp1,
(Min' m1) <- dp2
= checkOverflow (\m2 -> Time m2 ms0) m0 op0 m1 -- 6
| (Time m0 ms0) <- dp1,
(Ms' ms1) <- dp2
= checkOverflow (Time m0) ms0 op0 ms1 -- 7
| (Day m0) <- dp1,
(Day' m1) <- dp2
= checkOverflow Day m0 op0 m1 -- 8
| (Min m0) <- dp1,
(Min' m1) <- dp2
= checkOverflow Min m0 op0 m1 -- 9
| (Ms m0) <- dp1,
(Ms' m1) <- dp2
= checkOverflow Ms m0 op0 m1 -- 10
| (Day' m0) <- dp1,
(Day' m1) <- dp2
= checkOverflow Day' m0 op0 m1 -- 8
| (Min' m0) <- dp1,
(Min' m1) <- dp2
= checkOverflow Min' m0 op0 m1 -- 9
| (Ms' m0) <- dp1,
(Ms' m1) <- dp2
= checkOverflow Ms' m0 op0 m1 -- 10
| otherwise = Error Invalid
checkOverflow::forall a b. (Bounded a, Integral a, Num a) =>
(a -> DatePartSmall) -- ^ ctor
-> a
-> (Int -> Int -> Int) -- ^ op (+) (-)
-> a
-> DatePartSmall
checkOverflow ctor0 a1 op0 a2 =
if result1 >= min_aInt1
&& result1 <= max_aInt1
then ctor0 $ fi result1
else Error Overflow
where b1 = fi a1::Int
b2 = fi a2::Int
min_a1 = minBound::a
min_aInt1 = fi min_a1::Int
max_a1 = maxBound::a
max_aInt1 = fi max_a1::Int
result1 = op0 b1 b2::Int