module Data.Time.Range where
import Prelude (Eq, Int, Integer, Ord, Show,
fromInteger, toInteger, (*), (+), (<),
(<=), (==), (>=))
import Control.Applicative (Applicative, (<$>), (<|>))
import Control.Category ((.))
import Control.Lens (Choice, Optic', Prism', Rewrapped,
Unwrapped, from, makeClassy, makeLenses,
makeWrapped, prism', to, (^.), _1, _2,
_3, _Wrapped, (#))
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import Data.Text (Text)
import Data.Bool (Bool (..), (&&), (||))
import Data.Either (Either (..))
import Data.Function (const, ($))
import Data.Functor.Identity (Identity (..), runIdentity)
import Data.List (dropWhile, reverse)
import Data.List.NonEmpty (NonEmpty (..), unfold)
import Data.Maybe (Maybe (..), fromMaybe, maybe)
import Data.Monoid ((<>))
import Data.String (String)
import Data.Time (Day, UTCTime (..), addDays, addUTCTime,
defaultTimeLocale, fromGregorianValid,
parseTimeM, secondsToDiffTime,
showGregorian, toGregorian)
import Text.Read (readMaybe)
import Data.Time.Range.Types
class AsDay p f s where
_Day :: Optic' p f s Day
instance (Choice p, Applicative f) => AsDay p f (Integer, Int, Int) where
_Day = prism' toGregorian (\(y,m,d) -> fromGregorianValid y m d)
instance (Choice p, Applicative f) => AsDay p f String where
_Day = prism' showGregorian (parseTimeM False defaultTimeLocale "%Y-%m-%d")
dayParse :: String -> Either String Day
dayParse s = maybe err Right $
nom "%F" <|>
nom "%0Y%m%d" <|>
nom "%d/%m/%Y" <|>
nom "%D"
where
nom f = parseTimeM True defaultTimeLocale f s
err = Left $ "Unable to parse Date Accepts [yyyy-mm-dd, yyyymmdd, mm/dd/yy, dd/mm/yyyy]: " <> s
boundFromWrapped
:: ( Rewrapped s s
, Rewrapped e e
, Unwrapped s ~ Day
, Unwrapped e ~ Day
, Rewrapped hs hs
, Rewrapped he he
, Unwrapped hs ~ Natural
, Unwrapped he ~ Natural
)
=> s
-> e
-> hs
-> he
-> (LowerTimeBound, UpperTimeBound)
boundFromWrapped sd ed sh eh =
( (toUtc sd sh) ^. from _Wrapped
, (toUtc ed eh) ^. from _Wrapped
)
where
handle00 00 = h + m + s
where
h = 23 * 60 * 60
m = 59 * 60
s = 59
handle00 ss = ss * 60 * 60
toUtc d h = UTCTime
(d ^. _Wrapped)
(secondsToDiffTime
. handle00
. toInteger
$ h ^. _Wrapped
)
wrappedRange
:: ( Rewrapped a a
, Rewrapped b b
, Rewrapped c c
, Unwrapped a ~ t
, Unwrapped b ~ t
, Unwrapped c ~ t
, Ord t
)
=> (t -> c)
-> (t -> t)
-> a
-> b
-> NonEmpty c
wrappedRange con inc s e =
unfold next (s ^. _Wrapped . to con)
where
haveNext cc =
if (e ^. _Wrapped) < (cc ^. _Wrapped)
then Nothing
else Just cc
next c =
(c, c ^. _Wrapped . to (haveNext . con . inc))
strToHourNatural :: String -> Either String Natural
strToHourNatural s = maybe err toNat $ readMaybe (trim s)
where
trim = let f = reverse . dropWhile (== ' ') in f . f
err = Left ( "Unable to parse " <> s <>
" into acceptable hour value. Expected '1'-'23' or '00'"
)
toNat n = if isHour n then Right (fromInteger n) else err
isHour n = (n >= 1 && n <= 23) || (s == "00" && n == 0)
utcRangeHours
:: ( Rewrapped start start
, Rewrapped end end
, Unwrapped start ~ UTCTime
, Unwrapped end ~ UTCTime
)
=> start
-> end
-> NonEmpty UTCTime
utcRangeHours s e = runIdentity <$>
wrappedRange Identity (addUTCTime oneHour) s e
where
oneHour = 3600
datesInRange
:: ( Rewrapped a a
, Rewrapped b b
, Unwrapped a ~ Day
, Unwrapped b ~ Day
)
=> a -> b -> NonEmpty DayInRange
datesInRange =
wrappedRange (_Wrapped #) (addDays 1)
buildRanges
:: StartDate
-> Maybe EndDate
-> StartHour
-> EndHour
-> Ranges
buildRanges startD mayEndD startH endH =
Ranges lower upper neDays utcz
where
endD' = fromMaybe (startD ^. _Wrapped . to (_Wrapped #)) mayEndD
(lower, upper) = boundFromWrapped startD endD' startH endH
neDays = datesInRange startD endD'
utcz = utcRangeHours lower upper