{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
module Data.Deriving.Time
 ( Time(..)
 ) where

import qualified Data.Aeson as JS
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import qualified Data.Bytes.Get as Bytes
import qualified Data.Bytes.Put as Bytes
import qualified Data.Bytes.Serial as Bytes
import qualified Data.ByteString.Char8 as BC8
import           Data.Proxy
import qualified Data.Text as T
import           Data.Time
import           GHC.Generics
import           GHC.TypeLits

newtype Time t (s :: Symbol) = Time { f :: t }
  deriving (Eq, Ord, Generic)

instance (ParseTime t, KnownSymbol s) => JS.FromJSON (Time t s) where
  parseJSON =
    JS.withText "Time" $ \t ->
      case parseTimeM True defaultTimeLocale k (T.unpack t) of
        Just d -> pure (Time d)
        _      -> fail "could not parse MyTime"
    where
      k = symbolVal (Proxy @ s)

instance (FormatTime t, KnownSymbol s) => JS.ToJSON (Time t s) where
  toJSON = JS.toJSON . JS.String . T.pack . show
  toEncoding = JS.toEncoding . JS.String . T.pack . show

instance (ParseTime t, KnownSymbol s) => Read (Time t s) where
  readsPrec _ s =
      case parseTimeM True defaultTimeLocale k s of
        Just d -> [(Time d, mempty)]
        _      -> []
    where
      k = symbolVal (Proxy @ s)

instance (FormatTime t, KnownSymbol s) => Show (Time t s) where
  show (Time z) = formatTime defaultTimeLocale k z
    where
      k = symbolVal (Proxy @ s)

instance (ParseTime t, FormatTime t, KnownSymbol s) => Binary (Time t s) where
  get = do
    bs <- get
    case parseTimeM True defaultTimeLocale k (BC8.unpack bs) of
      Just d -> pure (Time d)
      _      -> fail "could not parse Time"
      where
        k = symbolVal (Proxy @ s)

  put (Time z) = put (BC8.pack $ formatTime defaultTimeLocale k z)
    where
      k = symbolVal (Proxy @ s)

instance (ParseTime t, FormatTime t, KnownSymbol s) => Bytes.Serial (Time t s) where
  deserialize = do
    bs <- Bytes.getBytes (length k)
    case parseTimeM True defaultTimeLocale k (BC8.unpack bs) of
      Just d -> pure (Time d)
      _      -> fail "could not parse Time"
      where
        k = symbolVal (Proxy @ s)

  serialize (Time z) = Bytes.putByteString (BC8.pack $ formatTime defaultTimeLocale k z)
    where
      k = symbolVal (Proxy @ s)