{-# LANGUAGE LambdaCase, TupleSections #-}
{-# LANGUAGE PatternSynonyms, ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Moffy.Handle.Time (
	-- * TimeState
	TimeState(..), Mode(InitialMode),
	-- * IO Mimicable
	TaiTimeM(..), DelayM(..),
	-- * Handle
	Timable, handleTimeEvPlus ) where

import Control.Arrow (first, second, (>>>))
import Control.Moffy.Event.Time (
	TimeEv, pattern OccDeltaTime, TryWait(..), pattern OccTryWait )
import Control.Moffy.Handle (
	ExpandableHandle, MergeableOccurred, HandleIo', expandIo, mergeIo )
import Control.Concurrent (threadDelay)
import Data.Type.Set ((:+:))
import Data.OneOrMore (project)
import Data.Time (DiffTime)
import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime, addAbsoluteTime)
import Data.Time.Clock.System (getSystemTime, systemToTAITime)

import Data.OneOrMoreApp (expand, pattern Singleton, (>-))
	
---------------------------------------------------------------------------

-- * TIME STATE
-- * IO MIMICABLE
-- * HANDLE

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

---------------------------------------------------------------------------
-- TIME STATE
---------------------------------------------------------------------------

class TimeState s where
	getMode :: s -> Mode; putMode :: s -> Mode -> s
	getLatestTime :: s -> AbsoluteTime
	putLatestTime :: s -> AbsoluteTime -> s

instance TimeState (Mode, AbsoluteTime) where
	getMode :: (Mode, AbsoluteTime) -> Mode
getMode = forall a b. (a, b) -> a
fst; putMode :: (Mode, AbsoluteTime) -> Mode -> (Mode, AbsoluteTime)
putMode (Mode, AbsoluteTime)
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Mode, AbsoluteTime)
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
	getLatestTime :: (Mode, AbsoluteTime) -> AbsoluteTime
getLatestTime = forall a b. (a, b) -> b
snd; putLatestTime :: (Mode, AbsoluteTime) -> AbsoluteTime -> (Mode, AbsoluteTime)
putLatestTime (Mode, AbsoluteTime)
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Mode, AbsoluteTime)
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

updateTimeState :: TimeState s => s -> (Mode, AbsoluteTime) -> s
updateTimeState :: forall s. TimeState s => s -> (Mode, AbsoluteTime) -> s
updateTimeState s
s (Mode
m, AbsoluteTime
t) = s
s forall s. TimeState s => s -> Mode -> s
`putMode` Mode
m forall s. TimeState s => s -> AbsoluteTime -> s
`putLatestTime` AbsoluteTime
t

data Mode = InitialMode | FlushWaitMode AbsoluteTime deriving Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show

mode :: a -> (AbsoluteTime -> a) -> Mode -> a
mode :: forall a. a -> (AbsoluteTime -> a) -> Mode -> a
mode a
im AbsoluteTime -> a
fwm = \case Mode
InitialMode -> a
im; FlushWaitMode AbsoluteTime
t -> AbsoluteTime -> a
fwm AbsoluteTime
t

---------------------------------------------------------------------------
-- IO MIMICABLE
---------------------------------------------------------------------------

class TaiTimeM m where getCurrentTime :: m AbsoluteTime
instance TaiTimeM IO where getCurrentTime :: IO AbsoluteTime
getCurrentTime = SystemTime -> AbsoluteTime
systemToTAITime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime
getSystemTime

class DelayM m where delay :: DiffTime -> m ()
instance DelayM IO where delay :: DiffTime -> IO ()
delay = Int -> IO ()
threadDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* DiffTime
10 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
6 :: Int))

---------------------------------------------------------------------------
-- HANDLE
---------------------------------------------------------------------------

type Timable es = (
	ExpandableHandle es (es :+: TimeEv),
	ExpandableHandle TimeEv (es :+: TimeEv),
	MergeableOccurred es TimeEv (es :+: TimeEv) )

handleTimeEvPlus :: (TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>
	HandleIo' ((DiffTime, a), s) s m es ->
	HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)
handleTimeEvPlus :: forall s (m :: * -> *) (es :: Set (*)) a.
(TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>
HandleIo' ((DiffTime, a), s) s m es
-> HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)
handleTimeEvPlus HandleIo' ((DiffTime, a), s) s m es
hdl EvReqs (es :+: TimeEv)
rqs i :: ((DiffTime, a), s)
i@((DiffTime, a)
_, s
s) = (forall a b. (a -> b) -> a -> b
$ s
s) forall a b. (a -> b) -> a -> b
$ forall s. TimeState s => s -> Mode
getMode
	forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. a -> (AbsoluteTime -> a) -> Mode -> a
mode (forall s (m :: * -> *) (es :: Set (*)) a.
(TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>
HandleIo' ((DiffTime, a), s) s m es
-> HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)
handleI HandleIo' ((DiffTime, a), s) s m es
hdl EvReqs (es :+: TimeEv)
rqs ((DiffTime, a), s)
i) (forall s (m :: * -> *) (es :: Set (*)).
(TimeState s, Monad m, ExpandableHandle TimeEv es) =>
HandleIo' ((AbsoluteTime, AbsoluteTime), s) s m es
handleF EvReqs (es :+: TimeEv)
rqs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, s
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, forall s. TimeState s => s -> AbsoluteTime
getLatestTime s
s))

handleI :: (TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>
	HandleIo' ((DiffTime, a), s) s m es ->
	HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)
handleI :: forall s (m :: * -> *) (es :: Set (*)) a.
(TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>
HandleIo' ((DiffTime, a), s) s m es
-> HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)
handleI HandleIo' ((DiffTime, a), s) s m es
hdl = forall (m :: * -> *) (es :: Set (*)) (es' :: Set (*)) i x o.
(Monad m, ExpandableHandle es (es :+: es'),
 ExpandableHandle es' (es :+: es'),
 MergeableOccurred es es' (es :+: es')) =>
HandleIo' i x m es
-> (i -> m x)
-> HandleIo' x o m es'
-> (x -> m o)
-> HandleIo' i o m (es :+: es')
mergeIo
	HandleIo' ((DiffTime, a), s) s m es
hdl (\((DiffTime
d, a
_), s
s) -> s
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). DelayM m => DiffTime -> m ()
delay DiffTime
d)
	(\EvReqs (TryWait ':~ (DeltaTime ':~ 'Nil))
rqs s
s -> (forall s. TimeState s => s -> (Mode, AbsoluteTime) -> s
updateTimeState s
s forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
`second`)
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *).
Monad m =>
HandleIo'
  (AbsoluteTime, AbsoluteTime) (Mode, AbsoluteTime) m TimeEv
handleTime EvReqs (TryWait ':~ (DeltaTime ':~ 'Nil))
rqs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, forall s. TimeState s => s -> AbsoluteTime
getLatestTime s
s) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). TaiTimeM m => m AbsoluteTime
getCurrentTime))
	((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TaiTimeM m => m AbsoluteTime
getCurrentTime) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. TimeState s => s -> AbsoluteTime -> s
putLatestTime)

handleF :: (TimeState s, Monad m, ExpandableHandle TimeEv es) =>
	HandleIo' ((AbsoluteTime, AbsoluteTime), s) s m es
handleF :: forall s (m :: * -> *) (es :: Set (*)).
(TimeState s, Monad m, ExpandableHandle TimeEv es) =>
HandleIo' ((AbsoluteTime, AbsoluteTime), s) s m es
handleF EvReqs es
rqs ((AbsoluteTime, AbsoluteTime)
nl, s
s) = (forall s. TimeState s => s -> (Mode, AbsoluteTime) -> s
updateTimeState s
s forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
`second`)
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (es :: Set (*)) (es' :: Set (*)) i o.
(Applicative m, ExpandableHandle es es') =>
HandleIo' i o m es -> (i -> m o) -> HandleIo' i o m es'
expandIo forall (m :: * -> *).
Monad m =>
HandleIo'
  (AbsoluteTime, AbsoluteTime) (Mode, AbsoluteTime) m TimeEv
handleTime (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Mode
InitialMode ,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) EvReqs es
rqs (AbsoluteTime, AbsoluteTime)
nl

handleTime :: Monad m =>
	HandleIo' (AbsoluteTime, AbsoluteTime) (Mode, AbsoluteTime) m TimeEv
handleTime :: forall (m :: * -> *).
Monad m =>
HandleIo'
  (AbsoluteTime, AbsoluteTime) (Mode, AbsoluteTime) m TimeEv
handleTime EvReqs TimeEv
rqs (AbsoluteTime
now, AbsoluteTime
lst) = case forall (as :: Set (*)) a.
Projectable as a =>
OneOrMore as -> Maybe a
project EvReqs TimeEv
rqs of
	Just (TryWaitReq DiffTime
t)
		| DiffTime
t forall a. Ord a => a -> a -> Bool
< DiffTime
dt  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (
			forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DiffTime -> Occurred TryWait
OccTryWait DiffTime
t forall a (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Insertable a as as' =>
a -> OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
>- forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton (DiffTime -> Occurred DeltaTime
OccDeltaTime DiffTime
t),
			(AbsoluteTime -> Mode
FlushWaitMode AbsoluteTime
now, DiffTime
t DiffTime -> AbsoluteTime -> AbsoluteTime
`addAbsoluteTime` AbsoluteTime
lst) )
		| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (
			forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DiffTime -> Occurred TryWait
OccTryWait DiffTime
dt forall a (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Insertable a as as' =>
a -> OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
>- forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton (DiffTime -> Occurred DeltaTime
OccDeltaTime DiffTime
dt),
			(Mode
InitialMode, AbsoluteTime
now) )
	Maybe TryWait
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (
		forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Expandable as as' =>
OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
expand forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton forall a b. (a -> b) -> a -> b
$ DiffTime -> Occurred DeltaTime
OccDeltaTime DiffTime
dt,
		(Mode
InitialMode, AbsoluteTime
now) )
	where dt :: DiffTime
dt = AbsoluteTime
now AbsoluteTime -> AbsoluteTime -> DiffTime
`diffAbsoluteTime` AbsoluteTime
lst