106 lines
3.1 KiB
Haskell
106 lines
3.1 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Utils.DateTime
|
|
( timeLocaleMap
|
|
, TimeLocale(..)
|
|
, currentYear
|
|
, DateTimeFormat(..)
|
|
, SelDateTimeFormat(..)
|
|
, module Data.Time.Zones
|
|
, module Data.Time.Zones.TH
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (lift)
|
|
import System.Locale.Read
|
|
|
|
import Data.Time (TimeZone(..), TimeLocale(..))
|
|
import Data.Time.Zones (TZ)
|
|
import Data.Time.Zones.TH (includeSystemTZ)
|
|
import Data.Time.Clock.POSIX
|
|
|
|
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
|
|
|
|
deriving instance Lift TimeZone
|
|
deriving instance Lift TimeLocale
|
|
|
|
instance Hashable UTCTime where
|
|
hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds
|
|
|
|
-- $(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 = SelFormatDateTime | SelFormatDate | SelFormatTime
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
|
|
|
|
instance Universe SelDateTimeFormat
|
|
instance Finite SelDateTimeFormat
|
|
instance Hashable SelDateTimeFormat
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
|
} ''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"
|