{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where
import Control.Monad (forever)
import Data.List.NonEmpty hiding (unfold)
import Data.Maybe (fromMaybe)
import GHC.TypeLits (Nat, KnownNat, natVal)
import Data.MonadicStreamFunction
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
import Control.Monad.Schedule
data Periodic (v :: [Nat]) where
Periodic :: Periodic (n : ns)
instance (Monad m, NonemptyNatList v)
=> Clock (ScheduleT Integer m) (Periodic v) where
type Time (Periodic v) = Integer
type Tag (Periodic v) = ()
initClock :: Periodic v
-> RunningClockInit
(ScheduleT Integer m) (Time (Periodic v)) (Tag (Periodic v))
initClock Periodic v
cl = (MSF (ScheduleT Integer m) () (Integer, ()), Integer)
-> FreeT
(Wait Integer)
m
(MSF (ScheduleT Integer m) () (Integer, ()), Integer)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
( NonEmpty Integer -> MSF (ScheduleT Integer m) () Integer
forall (m :: Type -> Type) a. Monad m => NonEmpty a -> MSF m () a
cycleS (Periodic v -> NonEmpty Integer
forall (v :: [Nat]).
NonemptyNatList v =>
Periodic v -> NonEmpty Integer
theList Periodic v
cl) MSF (ScheduleT Integer m) () Integer
-> MSF (ScheduleT Integer m) Integer (Integer, ())
-> MSF (ScheduleT Integer m) () (Integer, ())
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Integer -> FreeT (Wait Integer) m ())
-> MSF (ScheduleT Integer m) Integer Integer
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a a
withSideEffect Integer -> FreeT (Wait Integer) m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait MSF (ScheduleT Integer m) Integer Integer
-> MSF (ScheduleT Integer m) Integer (Integer, ())
-> MSF (ScheduleT Integer m) Integer (Integer, ())
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Integer -> Integer -> Integer)
-> Integer -> MSF (ScheduleT Integer m) Integer Integer
forall (m :: Type -> Type) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
0) MSF (ScheduleT Integer m) Integer Integer
-> MSF (ScheduleT Integer m) Integer ()
-> MSF (ScheduleT Integer m) Integer (Integer, ())
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Integer -> ()) -> MSF (ScheduleT Integer m) Integer ()
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> Integer -> ()
forall a b. a -> b -> a
const ())
, Integer
0
)
instance GetClockProxy (Periodic v)
data HeadClProxy (n :: Nat) where
HeadClProxy :: Periodic (n : ns) -> HeadClProxy n
headCl :: KnownNat n => Periodic (n : ns) -> Integer
headCl :: Periodic (n : ns) -> Integer
headCl Periodic (n : ns)
cl = HeadClProxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (HeadClProxy n -> Integer) -> HeadClProxy n -> Integer
forall a b. (a -> b) -> a -> b
$ Periodic (n : ns) -> HeadClProxy n
forall (n :: Nat) (ns :: [Nat]). Periodic (n : ns) -> HeadClProxy n
HeadClProxy Periodic (n : ns)
cl
tailCl :: Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)
tailCl :: Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)
tailCl Periodic (n1 : n2 : ns)
Periodic = Periodic (n2 : ns)
forall (n :: Nat) (ns :: [Nat]). Periodic (n : ns)
Periodic
class NonemptyNatList (v :: [Nat]) where
theList :: Periodic v -> NonEmpty Integer
instance KnownNat n => NonemptyNatList '[n] where
theList :: Periodic '[n] -> NonEmpty Integer
theList Periodic '[n]
cl = Periodic '[n] -> Integer
forall (n :: Nat) (ns :: [Nat]).
KnownNat n =>
Periodic (n : ns) -> Integer
headCl Periodic '[n]
cl Integer -> [Integer] -> NonEmpty Integer
forall a. a -> [a] -> NonEmpty a
:| []
instance (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns))
=> NonemptyNatList (n1 : n2 : ns) where
theList :: Periodic (n1 : n2 : ns) -> NonEmpty Integer
theList Periodic (n1 : n2 : ns)
cl = Periodic (n1 : n2 : ns) -> Integer
forall (n :: Nat) (ns :: [Nat]).
KnownNat n =>
Periodic (n : ns) -> Integer
headCl Periodic (n1 : n2 : ns)
cl Integer -> NonEmpty Integer -> NonEmpty Integer
forall a. a -> NonEmpty a -> NonEmpty a
<| Periodic (n2 : ns) -> NonEmpty Integer
forall (v :: [Nat]).
NonemptyNatList v =>
Periodic v -> NonEmpty Integer
theList (Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)
forall (n1 :: Nat) (n2 :: Nat) (ns :: [Nat]).
Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)
tailCl Periodic (n1 : n2 : ns)
cl)
cycleS :: Monad m => NonEmpty a -> MSF m () a
cycleS :: NonEmpty a -> MSF m () a
cycleS NonEmpty a
as = (NonEmpty a -> (a, NonEmpty a)) -> NonEmpty a -> MSF m () a
forall (m :: Type -> Type) a b.
Monad m =>
(a -> (b, a)) -> a -> MSF m () b
unfold ((Maybe (NonEmpty a) -> NonEmpty a)
-> (a, Maybe (NonEmpty a)) -> (a, NonEmpty a)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (NonEmpty a -> Maybe (NonEmpty a) -> NonEmpty a
forall a. a -> Maybe a -> a
fromMaybe NonEmpty a
as) ((a, Maybe (NonEmpty a)) -> (a, NonEmpty a))
-> (NonEmpty a -> (a, Maybe (NonEmpty a)))
-> NonEmpty a
-> (a, NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> (a, Maybe (NonEmpty a))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
uncons) NonEmpty a
as