66 lines
1.8 KiB
Haskell
66 lines
1.8 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, TemplateHaskell
|
|
, QuasiQuotes
|
|
, StandaloneDeriving
|
|
, DeriveLift
|
|
#-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Utils.DateTime
|
|
( timeLocaleMap
|
|
, TimeLocale(..)
|
|
, currentYear
|
|
, 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 Language.Haskell.TH
|
|
import Language.Haskell.TH.Syntax (Lift(..))
|
|
import Instances.TH.Lift ()
|
|
|
|
deriving instance Lift TimeZone
|
|
deriving instance Lift TimeLocale
|
|
|
|
|
|
-- $(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|]
|