live-sequencer-0.0.6.2: src/Time.hs

{-# LANGUAGE EmptyDataDecls #-}
{- | Similar to "Data.Fixed" -}
module Time (
    Time(Time),
    sub, up,
    Seconds,      seconds,
    Milliseconds, milliseconds,
    Microseconds, microseconds,
    Nanoseconds,  nanoseconds,
    pause,
    format,
    ) where

import Control.Concurrent ( threadDelay )
import Control.Applicative ( Const (Const, getConst) )

import qualified Data.Monoid as Mn
import qualified Data.Semigroup as Sg


newtype Time factor a = Time a
    deriving (Eq, Ord, Show)

instance Functor (Time factor) where
    fmap f (Time a) = Time (f a)


instance (Num a) => Sg.Semigroup (Time factor a) where
    Time x <> Time y = Time (x+y)

instance (Num a) => Mn.Monoid (Time factor a) where
    mempty = Time 0
    mappend = (Sg.<>)

sub :: Num a => Time factor a -> Time factor a -> Time factor a
sub (Time x) (Time y) = Time (x-y)


data One
data EM3 a

type Milli = EM3 One
type Micro = EM3 Milli
type Nano  = EM3 Micro

type Seconds      a = Time One   a
type Milliseconds a = Time Milli a  -- unit in Wait constructor
type Microseconds a = Time Micro a  -- unit of threadDelay
type Nanoseconds  a = Time Nano  a  -- unit of ALSA realtime


up :: Num a => Time factor a -> Time (EM3 factor) a
up (Time a) = Time (1000*a)


class Factor factor where
    seconds :: Num a => a -> Time factor a

instance Factor One where
    seconds = Time

instance Factor factor => Factor (EM3 factor) where
    seconds = up . seconds


div1000 :: Time factor a -> Time (EM3 factor) a
div1000 (Time t) = Time t

milliseconds :: (Factor factor, Num a) => a -> Time (EM3 factor) a
milliseconds = div1000 . seconds

microseconds :: (Factor factor, Num a) => a -> Time (EM3 (EM3 factor)) a
microseconds = div1000 . milliseconds

nanoseconds :: (Factor factor, Num a) => a -> Time (EM3 (EM3 (EM3 factor))) a
nanoseconds = div1000 . microseconds


pause :: Time Micro Int -> IO ()
pause (Time t) = threadDelay t



-- | we check by the types whether we can format the time value or not
class Factor factor =>
      Format factor where formatUnit :: Const String factor
instance Format One where formatUnit = Const "s"

class Factor factor =>
      Format1 factor where formatUnit1 :: Const String (EM3 factor)
instance Format1 One where formatUnit1 = Const "ms"

class Factor factor =>
      Format2 factor where formatUnit2 :: Const String (EM3 (EM3 factor))
instance Format2 One where formatUnit2 = Const "us"

class Factor factor =>
      Format3 factor where formatUnit3 :: Const String (EM3 (EM3 (EM3 factor)))
instance Format3 One where formatUnit3 = Const "ns"

instance Format1 factor => Format  (EM3 factor) where formatUnit  = formatUnit1
instance Format2 factor => Format1 (EM3 factor) where formatUnit1 = formatUnit2
instance Format3 factor => Format2 (EM3 factor) where formatUnit2 = formatUnit3


format :: (Format factor, Show a) => Time factor a -> String
format time@(Time t) = show t ++ getConst (formatUnitFromTime time)

formatUnitFromTime :: (Format factor) => Time factor a -> Const String factor
formatUnitFromTime = const formatUnit