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