liblawless-0.20.1: Source/Time.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Time
  (
    Time,
    Seconds,
    ParseTime(..),
    FormatTime(..),
    _Time,
    day,
    time,
    now,
    seconds
  ) where

import Data.Binary
import Data.Char
import Data.Data
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format
import Generics
import IO (MonadIO, liftIO)
import Lawless
import Text
import qualified Textual as T
import qualified Parser as P
import Aeson

default (Text)

newtype Time = Time UTCTime deriving (Show, Eq, Ord, ParseTime, FormatTime, Generic)
makePrisms ''Time

deriving instance ToJSON Time
deriving instance FromJSON Time

timeFormat ∷ [Char]
timeFormat = (iso8601DateFormat (Just "%H:%M:%S.%q%z"))

-- | 'Lens' for the 'Day' component of a 'Time'.
day :: Lens' Time Day
day = lens (utctDay ∘ view _Time) (\(Time (UTCTime{..})) d → Time $ UTCTime d utctDayTime)

-- | 'Lens' for the 'DiffTime' component of a 'Time'.
time ∷ Lens' Time DiffTime
time = lens (utctDayTime ∘ view _Time) (\(Time (UTCTime{..})) t → Time $ UTCTime utctDay t)

-- | Get the current system time.
now ∷ MonadIO m ⇒ m Time
now = liftIO $ Time <$> getCurrentTime

newtype Seconds = Seconds DiffTime
    deriving (Eq, Ord, Show, Enum, Fractional, Data, Num, Real, RealFrac)

-- | Convert between 'Double' and 'Seconds'.
seconds ∷ Iso' Double DiffTime
seconds = iso (fromRational ∘ toRational) (fromRational ∘ toRational)

instance FromJSON Seconds where
    parseJSON (Number n) = return $ Seconds (fromRational ∘ toRational $ n)
    parseJSON v = typeMismatch "Seconds" v

instance ToJSON Seconds where
    toJSON = Number ∘ fromRational ∘ toRational

instance Binary Seconds where
    put = put ∘ toRational
    get = Seconds ∘ fromRational <$> get

instance Binary Time where
  put t =
    put (toModifiedJulianDay (t ^. day)) >>
    put (toRational (t ^. time))

  get = do
    d ← ModifiedJulianDay <$> get
    t ← fromRational <$> get
    return ∘ Time $ UTCTime d t

instance T.Printable Time where
  print = T.print ∘formatTime defaultTimeLocale timeFormat

parseTimeFormats ∷ [[Char]]
parseTimeFormats = over traversed (iso8601DateFormat ∘ Just) [
    "%H:%M:%S%Q%z",
    "%H:%M:%S%QZ"
    ]

instance T.Textual Time where
    textual =
        let
            r = P.some
                (P.satisfy
                    (\c → isAlphaNum c ∨ anyOf traversed (c≡) (":+-." ∷ [Char]))
                )
            p f = (parseTimeM False defaultTimeLocale f)
        in
            P.choice $ over traversed (\f → P.try $ p f =≪ r) parseTimeFormats