{-# 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