Main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
module Main where

import Data.Aeson hiding (decode, encode)
import Data.Binary
import Data.Binary.Get
import qualified Data.ByteString.Char8 as BC8
import Data.Proxy
import Data.Text
import Data.Time
import GHC.Generics
import GHC.TypeLits

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

newtype MyTime = MT { lt :: LocalTime }
  deriving Show
  deriving (Read, Binary, FromJSON) via (Time "%M/%d/%y %H:%M:%S")

main :: IO ()
main = do
  print @(Result MyTime) $
    fromJSON (String "09/01/87 10:10:02")
  print (read "09/01/87 10:10:02" :: MyTime)
  let a = decode "09/01/87 10:10:02" :: MyTime
  print a
  -- print (decode (encode a) :: MyTime)

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

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

instance KnownSymbol s => Binary (Time s) where
    get = do
      bs <- getByteString (Prelude.length k)
      case parseTimeM True defaultTimeLocale k (BC8.unpack bs) of
        Just d -> pure (Time d)
        _      -> fail "could not parse MyTime"
        where
          k = symbolVal (Proxy @ s)
    put (Time z) = put (Prelude.length k) <>
      put (formatTime defaultTimeLocale k z)
      where
        k = symbolVal (Proxy @ s)