fradrive/src/Utils/DateTime.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Utils.DateTime
  ( timeLocaleMap
  , TimeLocale(..)
  , compileTime
  , currentYear
  , HasLocalTime(..)
  , DateTimeFormat(..)
  , SelDateTimeFormat(..)
  , DateTimeFormatter(..)
  , mkDateTimeFormatter
  , nominalHour, nominalMinute
  , minNominalYear, avgNominalYear
  , diffMinute, diffHour, diffDay
  , module Zones  
  , day
  , utctDayMidnight
  ) where

import ClassyPrelude.Yesod hiding (lift, Proxy(..))
import System.Locale.Read
import Data.Proxy

import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..), DiffTime)
import Data.Time.Zones as Zones (TZ)
import Data.Time.Zones.TH as Zones (includeSystemTZ)
import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
import Data.Time.Format (FormatTime)
import Data.Time.Format.Instances ()
import Data.Time.Clock.System (systemEpochDay)
import qualified Data.Time.Format.ISO8601 as Time
import qualified Data.Time.Format as Time
-- import Data.Time.Calendar (CalendarDiffDays, calendarMonth, scaleCalendarDiffDays)

import qualified Data.List.NonEmpty as NonEmpty

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Instances.TH.Lift ()

import Data.Data (Data)
import Data.Universe

import Database.Persist.Sql (PersistFieldSql(..))

import Utils.PathPiece

import Algebra.Lattice
import Algebra.Lattice.Ordered

import Control.Monad.Fail

import Utils.Lang (selectLanguage')


-- Usage like so: $(timeLocaleMap _) :: [Lang] -> TimeLocale
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
              -> ExpQ
timeLocaleMap [] = fail "Need at least one (language, locale)-pair"
timeLocaleMap extra@((_, defLocale):_) = do
  localeMap <- newName "localeMap"

  let
    langs = NonEmpty.fromList $ map fst extra

    localeMap' = funD localeMap $ map matchLang extra ++ [defaultLang]

    defaultLang :: ClauseQ
    defaultLang =
      clause [listP []] (normalB $ localeExp defLocale) []

    matchLang :: (Lang, String) -> ClauseQ
    matchLang (lang, localeStr) = do
      lang' <- newName "lang"
      clause [varP lang'] (guardedB [(,) <$> normalG [e|selectLanguage' langs $(varE lang') == lang|] <*> localeExp localeStr]) []

    localeExp :: String -> ExpQ
    localeExp = lift <=< runIO . getLocale . Just

  letE [localeMap'] (varE localeMap)

compileTime :: ExpQ -- Type UTCTime
compileTime = do 
  now <- runIO getCurrentTime
  [e|now|]

currentYear :: ExpQ
currentYear = do
  now <- runIO getCurrentTime
  let (year, _, _) = toGregorian $ utctDay now
  [e|year|]

class FormatTime t => HasLocalTime t where
  toLocalTime :: t -> LocalTime

instance HasLocalTime LocalTime where
  toLocalTime = id

instance HasLocalTime Day where
  toLocalTime d = LocalTime d midnight

instance HasLocalTime TimeOfDay where
  toLocalTime = LocalTime systemEpochDay

newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
  deriving (Eq, Ord, Read, Show, Data, Generic)
  deriving newtype (ToJSON, FromJSON, PersistField, IsString)
  deriving anyclass (NFData)

instance PersistFieldSql DateTimeFormat where
  sqlType _ = sqlType $ Proxy @String

instance Hashable DateTimeFormat

data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic)
  deriving anyclass (Universe, Finite, Hashable, NFData)

nullaryPathPiece ''SelDateTimeFormat $ camelToPathPiece' 2
pathPieceJSON ''SelDateTimeFormat
pathPieceJSONKey ''SelDateTimeFormat

instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
  def SelFormatDateTime = "%c"
  def SelFormatDate     = "%F"
  def SelFormatTime     = "%T"

instance Lattice SelDateTimeFormat where
  a \/ b = getOrdered $ ((\/) `on` Ordered) a b
  a /\ b = getOrdered $ ((/\) `on` Ordered) a b

instance BoundedJoinSemiLattice SelDateTimeFormat where
  bottom = SelFormatTime

instance BoundedMeetSemiLattice SelDateTimeFormat where
  top = SelFormatDateTime

newtype DateTimeFormatter = DateTimeFormatter { format :: forall t. HasLocalTime t => SelDateTimeFormat -> t -> Text }

mkDateTimeFormatter :: TimeLocale -> (SelDateTimeFormat -> DateTimeFormat) -> TZ -> DateTimeFormatter
mkDateTimeFormatter locale formatMap appTZ = DateTimeFormatter (\(formatMap -> fmt) t -> pack . Time.formatTime locale (unDateTimeFormat fmt) $ ZonedTime (toLocalTime t) (timeZoneForUTCTime appTZ . localTimeToUTCTZ appTZ $ toLocalTime t))

---------------------
-- NominalDiffTime --
---------------------

-- | One hour in `NominalDiffTime`.
nominalHour :: NominalDiffTime
nominalHour = 3600

-- | One minute in `NominalDiffTime`.
nominalMinute :: NominalDiffTime
nominalMinute = 60

minNominalYear, avgNominalYear :: NominalDiffTime
minNominalYear = 365 * nominalDay
avgNominalYear = fromRational $ 365.2425 * toRational nominalDay

--------------
-- DiffTime --
--------------

diffMinute, diffHour, diffDay :: DiffTime
diffMinute = 60
diffHour = 3600
diffDay = 86400

---------
-- Day --
---------

day :: QuasiQuoter
day = QuasiQuoter{..}
  where
    quotePat = error "day used as pattern"
    quoteType = error "day used as type"
    quoteDec = error "day used as declaration"
    quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr

-- | use Handler.Utils.DateTime.toMidnight instead, if the local timezone is to be accounted for
utctDayMidnight :: Day -> UTCTime
utctDayMidnight d = UTCTime { utctDayTime = 0, utctDay = d }