139 lines
3.8 KiB
Haskell
139 lines
3.8 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 (TimeLocale(..), NominalDiffTime, nominalDay)
|
|
import Data.Time.Zones (TZ)
|
|
import Data.Time.Zones.TH (includeSystemTZ)
|
|
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Syntax (Lift(..))
|
|
import Instances.TH.Lift ()
|
|
|
|
import Data.Data (Data)
|
|
import Data.Typeable (Typeable)
|
|
import Data.Universe
|
|
|
|
import Database.Persist.Sql (PersistField, PersistFieldSql)
|
|
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
|
|
import Utils.PathPiece
|
|
|
|
import Data.Time.Format.Instances ()
|
|
|
|
import Algebra.Lattice
|
|
import Algebra.Lattice.Ordered
|
|
|
|
|
|
-- $(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
|
|
localeMap' = funD localeMap $ map matchLang extra ++ [reduceLangList, defaultLang]
|
|
|
|
defaultLang :: ClauseQ
|
|
defaultLang =
|
|
clause [listP []] (normalB $ localeExp defLocale) []
|
|
|
|
reduceLangList :: ClauseQ
|
|
reduceLangList = do
|
|
ls <- newName "ls"
|
|
clause [[p|(_ : $(varP ls))|]] (normalB [e|$(varE localeMap) $(varE ls)|]) []
|
|
|
|
matchLang :: (Lang, String) -> ClauseQ
|
|
matchLang (lang, localeStr) = do
|
|
lang' <- newName "lang"
|
|
clause [[p|($(varP lang') : _)|]] (guardedB [(,) <$> normalG [e|$(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
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece' 2
|
|
} ''SelDateTimeFormat
|
|
|
|
instance ToJSONKey SelDateTimeFormat where
|
|
toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt
|
|
instance FromJSONKey SelDateTimeFormat where
|
|
fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
|
|
|
|
instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
|
|
def SelFormatDateTime = "%c"
|
|
def SelFormatDate = "%F"
|
|
def SelFormatTime = "%T"
|
|
|
|
instance JoinSemiLattice SelDateTimeFormat where
|
|
a \/ b = getOrdered $ ((\/) `on` Ordered) a b
|
|
|
|
instance MeetSemiLattice SelDateTimeFormat where
|
|
a /\ b = getOrdered $ ((/\) `on` Ordered) a b
|
|
|
|
instance Lattice SelDateTimeFormat
|
|
|
|
instance BoundedJoinSemiLattice SelDateTimeFormat where
|
|
bottom = SelFormatTime
|
|
|
|
instance BoundedMeetSemiLattice SelDateTimeFormat where
|
|
top = SelFormatDateTime
|
|
|
|
instance BoundedLattice SelDateTimeFormat
|
|
|
|
|
|
---------------------
|
|
-- 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
|