124 lines
3.3 KiB
Haskell
124 lines
3.3 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Utils.DateTime
|
|
( timeLocaleMap
|
|
, TimeLocale(..)
|
|
, currentYear
|
|
, DateTimeFormat(..)
|
|
, SelDateTimeFormat(..)
|
|
, nominalHour, nominalMinute
|
|
, minNominalYear, avgNominalYear
|
|
, module Data.Time.Zones
|
|
, module Data.Time.Zones.TH
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (lift)
|
|
import System.Locale.Read
|
|
|
|
import Data.Time (NominalDiffTime, nominalDay)
|
|
import Data.Time.Zones (TZ)
|
|
import Data.Time.Zones.TH (includeSystemTZ)
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Syntax (Lift(..))
|
|
import Instances.TH.Lift ()
|
|
|
|
import Data.Data (Data)
|
|
import Data.Universe
|
|
|
|
import Database.Persist.Sql (PersistFieldSql)
|
|
|
|
import Utils.PathPiece
|
|
|
|
import Data.Time.Format.Instances ()
|
|
|
|
import Algebra.Lattice
|
|
import Algebra.Lattice.Ordered
|
|
|
|
import Control.Monad.Fail
|
|
|
|
|
|
-- $(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)
|
|
|
|
currentYear :: ExpQ
|
|
currentYear = do
|
|
now <- runIO getCurrentTime
|
|
let (year, _, _) = toGregorian $ utctDay now
|
|
[e|year|]
|
|
|
|
|
|
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
|
|
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
|
|
deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
|
|
|
|
instance Hashable DateTimeFormat
|
|
|
|
data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
|
|
|
|
instance Universe SelDateTimeFormat
|
|
instance Finite SelDateTimeFormat
|
|
instance Hashable SelDateTimeFormat
|
|
|
|
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
|
|
|
|
|
|
---------------------
|
|
-- 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
|