metabrush/src/app/MetaBrush/Time.hs

{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms            #-}

module MetaBrush.Time
  ( Time(..), DTime(DSeconds, ..), dSeconds 
  , pprSeconds
  , monotonicTime
  )
  where

-- base
import Data.Int
  ( Int64 )
import Data.Semigroup
  ( Sum(..) )

-- acts
import Data.Act
  ( Act, Torsor )

-- gi-glib
import qualified GI.GLib.Functions as GLib
  ( getMonotonicTime )

-- groups
import Data.Group
  ( Group )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO )

--------------------------------------------------------------------------------

newtype Time = Seconds { seconds :: Double }
  deriving newtype ( Eq, Ord )
  deriving stock   Show
  deriving ( Act DTime, Torsor DTime )
    via DTime

newtype DTime = DTime { dTime :: Time }
  deriving stock   Show
  deriving newtype ( Eq, Ord )
  deriving ( Semigroup, Monoid, Group )
     via ( Sum Double )

{-# COMPLETE DSeconds #-}
pattern DSeconds :: Double -> DTime
pattern DSeconds secs = DTime ( Seconds secs )

dSeconds :: DTime -> Double
dSeconds ( DSeconds secs ) = secs

pprSeconds :: ( String, String, String ) -> Time -> String
pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
  where
    pm :: String
    pm
      | secs <= (-1) = "-"
      | otherwise    = ""
    h, r, m, s :: Int64
    (h,r) = ( round $ abs secs ) `divMod` 3600
    (m,s) = r                    `divMod` 60
    fixed2 :: String -> String
    fixed2 []  = "00"
    fixed2 [x] = ['0', x]
    fixed2 xs  = xs
    absolute
      | h > 0     = show h <> h_name <> fixed2 (show m) <> m_name <> fixed2 (show s) <> s_name
      | m > 0     =                             show m  <> m_name <> fixed2 (show s) <> s_name
      | otherwise =                                                          show s  <> s_name

monotonicTime :: MonadIO m => m Time
monotonicTime = Seconds . ( * 1e-6 ) . fromIntegral <$> GLib.getMonotonicTime