{-# OPTIONS -Wall #-}
{-# OPTIONS -Wno-compat #-}
{-# OPTIONS -Wincomplete-record-updates #-}
{-# OPTIONS -Wincomplete-uni-patterns #-}
{-# OPTIONS -Wredundant-constraints #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE NoStarIsType #-}
module Predicate.Data.DateTime (
FormatTimeP
, ParseTimeP
, ParseTimeP'
, ParseTimes
, ParseTimes'
, MkDay
, MkDay'
, MkDayExtra
, MkDayExtra'
, MkTime
, MkTime'
, PosixToUTCTime
, UnMkDay
, ToWeekDate
, ToWeekYear
, ToDay
, ToTime
, UnMkTime
, UTCTimeToPosix
) where
import Predicate.Core
import Predicate.Util
import Control.Lens hiding (iall)
import Data.Proxy
import Data.Typeable
import Data.Kind (Type)
import Data.Maybe
import Data.Time
import Data.Time.Calendar.WeekDate
import qualified Data.Time.Clock.System as CP
import qualified Data.Time.Clock.POSIX as P
data FormatTimeP p q
instance (PP p x ~ String
, FormatTime (PP q x)
, P p x
, Show (PP q x)
, P q x
) => P (FormatTimeP p q) x where
type PP (FormatTimeP p q) x = String
eval _ opts x = do
let msg0 = "FormatTimeP"
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x []
pure $ case lr of
Left e -> e
Right (p,q,pp,qq) ->
let msg1 = msg0 <> " (" <> p <> ")"
b = formatTime defaultTimeLocale p q
in mkNode opts (PresentT b) (msg1 <> " " <> litL opts b <> showVerbose opts " | " q) [hh pp, hh qq]
data ParseTimeP' t p q
instance (ParseTime (PP t a)
, Typeable (PP t a)
, Show (PP t a)
, P p a
, P q a
, PP p a ~ String
, PP q a ~ String
) => P (ParseTimeP' t p q) a where
type PP (ParseTimeP' t p q) a = PP t a
eval _ opts a = do
let msg0 = "ParseTimeP " <> t
t = showT @(PP t a)
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a []
pure $ case lr of
Left e -> e
Right (p,q,pp,qq) ->
let msg1 = msg0 <> " (" <> p <> ")"
hhs = [hh pp, hh qq]
in case parseTimeM @Maybe @(PP t a) True defaultTimeLocale p q of
Just b -> mkNode opts (PresentT b) (lit01 opts msg1 b "fmt=" p <> showVerbose opts " | " q) hhs
Nothing -> mkNode opts (FailT (msg1 <> " failed to parse")) "" hhs
data ParseTimeP (t :: Type) p q
type ParseTimePT (t :: Type) p q = ParseTimeP' (Hole t) p q
instance P (ParseTimePT t p q) x => P (ParseTimeP t p q) x where
type PP (ParseTimeP t p q) x = PP (ParseTimePT t p q) x
eval _ = eval (Proxy @(ParseTimePT t p q))
data ParseTimes' t p q
instance (ParseTime (PP t a)
, Typeable (PP t a)
, Show (PP t a)
, P p a
, P q a
, PP p a ~ [String]
, PP q a ~ String
) => P (ParseTimes' t p q) a where
type PP (ParseTimes' t p q) a = PP t a
eval _ opts a = do
let msg0 = "ParseTimes " <> t
t = showT @(PP t a)
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a []
pure $ case lr of
Left e -> e
Right (p,q,pp,qq) ->
let hhs = [hh pp, hh qq]
zs = map (\d -> (d,) <$> parseTimeM @Maybe @(PP t a) True defaultTimeLocale d q) p
in case catMaybes zs of
[] -> mkNode opts (FailT ("no match on (" ++ q ++ ")")) msg0 hhs
(d,b):_ -> mkNode opts (PresentT b) (lit01 opts msg0 b "fmt=" d <> showVerbose opts " | " q) hhs
data ParseTimes (t :: Type) p q
type ParseTimesT (t :: Type) p q = ParseTimes' (Hole t) p q
instance P (ParseTimesT t p q) x => P (ParseTimes t p q) x where
type PP (ParseTimes t p q) x = PP (ParseTimesT t p q) x
eval _ = eval (Proxy @(ParseTimesT t p q))
data MkDay' p q r
instance (P p x
, P q x
, P r x
, PP p x ~ Int
, PP q x ~ Int
, PP r x ~ Int
) => P (MkDay' p q r) x where
type PP (MkDay' p q r) x = Maybe Day
eval _ opts x = do
let msg0 = "MkDay"
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x []
case lr of
Left e -> pure e
Right (p,q,pp,qq) -> do
let hhs = [hh pp, hh qq]
rr <- eval (Proxy @r) opts x
pure $ case getValueLR opts msg0 rr hhs of
Left e -> e
Right r ->
let mday = fromGregorianValid (fromIntegral p) q r
in mkNode opts (PresentT mday) (show01' opts msg0 mday "(y,m,d)=" (p,q,r)) (hhs <> [hh rr])
data MkDay p
type MkDayT p = MkDay' (Fst p) (Snd p) (Thd p)
instance P (MkDayT p) x => P (MkDay p) x where
type PP (MkDay p) x = PP (MkDayT p) x
eval _ = eval (Proxy @(MkDayT p))
data UnMkDay p
instance ( PP p x ~ Day
, P p x
) => P (UnMkDay p) x where
type PP (UnMkDay p) x = (Int, Int, Int)
eval _ opts x = do
let msg0 = "UnMkDay"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let (fromIntegral -> y, m, d) = toGregorian p
b = (y, m, d)
in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp]
data MkDayExtra' p q r
instance (P p x
, P q x
, P r x
, PP p x ~ Int
, PP q x ~ Int
, PP r x ~ Int
) => P (MkDayExtra' p q r) x where
type PP (MkDayExtra' p q r) x = Maybe (Day, Int, Int)
eval _ opts x = do
let msg0 = "MkDayExtra"
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x []
case lr of
Left e -> pure e
Right (p,q,pp,qq) -> do
let hhs = [hh pp, hh qq]
rr <- eval (Proxy @r) opts x
pure $ case getValueLR opts msg0 rr hhs of
Left e -> e
Right r ->
let mday = fromGregorianValid (fromIntegral p) q r
b = mday <&> \day ->
let (_, week, dow) = toWeekDate day
in (day, week, dow)
in mkNode opts (PresentT b) (show01' opts msg0 b "(y,m,d)=" (p,q,r)) (hhs <> [hh rr])
data MkDayExtra p
type MkDayExtraT p = MkDayExtra' (Fst p) (Snd p) (Thd p)
instance P (MkDayExtraT p) x => P (MkDayExtra p) x where
type PP (MkDayExtra p) x = PP (MkDayExtraT p) x
eval _ = eval (Proxy @(MkDayExtraT p))
data ToWeekDate p
instance ( P p x
, PP p x ~ Day
) => P (ToWeekDate p) x where
type PP (ToWeekDate p) x = (Int, String)
eval _ opts x = do
let msg0 = "ToWeekDate"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let (_, _week, dow) = toWeekDate p
dowString =
case dow of
1 -> "Monday"
2 -> "Tuesday"
3 -> "Wednesday"
4 -> "Thursday"
5 -> "Friday"
6 -> "Saturday"
7 -> "Sunday"
_ -> error $ "oops: ToWeekDate invalid " ++ show dow
in mkNode opts (PresentT (dow,dowString)) (show01 opts msg0 dow p) [hh pp]
data ToWeekYear p
instance ( P p x
, PP p x ~ Day
) => P (ToWeekYear p) x where
type PP (ToWeekYear p) x = Int
eval _ opts x = do
let msg0 = "ToWeekYear"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let (_, week, _dow) = toWeekDate p
in mkNode opts (PresentT week) (show01 opts msg0 week p) [hh pp]
class ToDayC a where
getDay :: a -> Day
instance ToDayC UTCTime where
getDay = utctDay
instance ToDayC ZonedTime where
getDay = getDay . zonedTimeToLocalTime
instance ToDayC LocalTime where
getDay = localDay
instance ToDayC Day where
getDay = id
instance ToDayC Rational where
getDay = getDay . P.posixSecondsToUTCTime . fromRational
instance ToDayC CP.SystemTime where
getDay = getDay . CP.systemToUTCTime
class ToTimeC a where
getTime :: a -> TimeOfDay
instance ToTimeC UTCTime where
getTime = getTime . utctDayTime
instance ToTimeC ZonedTime where
getTime = getTime . zonedTimeToLocalTime
instance ToTimeC LocalTime where
getTime = localTimeOfDay
instance ToTimeC TimeOfDay where
getTime = id
instance ToTimeC DiffTime where
getTime = timeToTimeOfDay
instance ToTimeC Rational where
getTime = getTime . P.posixSecondsToUTCTime . fromRational
instance ToTimeC CP.SystemTime where
getTime = getTime . CP.systemToUTCTime
data ToDay p
instance ( P p x
, Show (PP p x)
, ToDayC (PP p x)
) => P (ToDay p) x where
type PP (ToDay p) x = Day
eval _ opts x = do
let msg0 = "ToDay"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let ret = getDay p
in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp]
data ToTime p
instance ( P p x
, Show (PP p x)
, ToTimeC (PP p x)
) => P (ToTime p) x where
type PP (ToTime p) x = TimeOfDay
eval _ opts x = do
let msg0 = "ToTime"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let ret = getTime p
in mkNode opts (PresentT ret) (show01 opts msg0 ret p) [hh pp]
data MkTime' p q r
instance (P p x
, P q x
, P r x
, PP p x ~ Int
, PP q x ~ Int
, PP r x ~ Rational
) => P (MkTime' p q r) x where
type PP (MkTime' p q r) x = TimeOfDay
eval _ opts x = do
let msg0 = "MkTime"
lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x []
case lr of
Left e -> pure e
Right (p,q,pp,qq) -> do
let hhs = [hh pp, hh qq]
rr <- eval (Proxy @r) opts x
pure $ case getValueLR opts msg0 rr hhs of
Left e -> e
Right r ->
let mtime = TimeOfDay p q (fromRational r)
in mkNode opts (PresentT mtime) (show01' opts msg0 mtime "(h,m,s)=" (p,q,r)) (hhs <> [hh rr])
data MkTime p
type MkTimeT p = MkTime' (Fst p) (Snd p) (Thd p)
instance P (MkTimeT p) x => P (MkTime p) x where
type PP (MkTime p) x = PP (MkTimeT p) x
eval _ = eval (Proxy @(MkTimeT p))
data UnMkTime p
instance ( PP p x ~ TimeOfDay
, P p x
) => P (UnMkTime p) x where
type PP (UnMkTime p) x = (Int, Int, Rational)
eval _ opts x = do
let msg0 = "UnMkTime"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let TimeOfDay h m s = p
b = (h, m, toRational s)
in mkNode opts (PresentT b) (show01 opts msg0 b p) [hh pp]
data PosixToUTCTime p
instance ( PP p x ~ Rational
, P p x
) => P (PosixToUTCTime p) x where
type PP (PosixToUTCTime p) x = UTCTime
eval _ opts x = do
let msg0 = "PosixToUTCTime"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let d = P.posixSecondsToUTCTime (fromRational p)
in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp]
data UTCTimeToPosix p
instance ( PP p x ~ UTCTime
, P p x
) => P (UTCTimeToPosix p) x where
type PP (UTCTimeToPosix p) x = Rational
eval _ opts x = do
let msg0 = "UTCTimeToPosix"
pp <- eval (Proxy @p) opts x
pure $ case getValueLR opts msg0 pp [] of
Left e -> e
Right p ->
let d = toRational $ P.utcTimeToPOSIXSeconds p
in mkNode opts (PresentT d) (show01 opts msg0 d p) [hh pp]