diff options
author | Alexander Foremny <aforemny@posteo.de> | 2023-10-14 14:56:42 +0200 |
---|---|---|
committer | Alexander Foremny <aforemny@posteo.de> | 2023-10-16 10:27:54 +0200 |
commit | 42fc137f64aab9242aab9bdb2f5da0a6d892f09c (patch) | |
tree | c83753abf6abeb354cbce389b2b637bde297ad76 | |
parent | 8d6a71ace58889110fc61f8384f7554c42ed3d8a (diff) |
fix UTCTime serialization
-rw-r--r-- | app/Issue.hs | 24 |
1 files changed, 19 insertions, 5 deletions
diff --git a/app/Issue.hs b/app/Issue.hs index c9d18f8..256947b 100644 --- a/app/Issue.hs +++ b/app/Issue.hs @@ -3,17 +3,20 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Issue (Issue (..), Provenance (..), fromMatch, id) where -import Data.Binary (Binary, get, put) +import Data.Binary (Binary, Put, get, put) import Data.ByteString.Lazy (toStrict) +import Data.Fixed (Pico) import Data.Function ((&)) import Data.List (find, foldl') import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8) -import Data.Time.Clock (UTCTime) +import Data.Time.Calendar (Day (..), toModifiedJulianDay) +import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime) import GHC.Generics (Generic) import Issue.Tag (Tag (..)) import Issue.Tag qualified as I @@ -46,10 +49,21 @@ data Provenance = Provenance } deriving (Show, Generic, Binary) +-- XXX These are taken from `Data.Binary.Orphans` [1]. I cannot get importing +-- the instance from the package to work.. so we use `-fno-warn-orphans` here. +-- +-- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132 instance Binary UTCTime where - -- TODO Serialize UTCTime using POSIX time stamps - put = put . show - get = fmap read get + get = UTCTime <$> get <*> get + put (UTCTime d dt) = put d >> put dt + +instance Binary Day where + get = fmap ModifiedJulianDay get + put = put . toModifiedJulianDay + +instance Binary DiffTime where + get = fmap picosecondsToDiffTime get + put = (put :: Pico -> Put) . realToFrac id :: Issue -> Maybe String id issue = |