{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{- |
Periodic clocks are defined by a stream of ticks with periodic time differences.
They model subclocks of a fixed reference clock.
The time differences are supplied at the type level.
-}
module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where

-- base
import Control.Arrow
import Data.List.NonEmpty hiding (unfold)
import GHC.TypeLits (KnownNat, Nat, natVal)

-- monad-schedule
import Control.Monad.Schedule.Trans

-- automaton
import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy

-- * The 'Periodic' clock

{- | A clock whose tick lengths cycle through
   a (nonempty) list of type-level natural numbers.
   E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc.

   The waiting side effect is formal, in 'ScheduleT'.
   You can use e.g. 'runScheduleIO' to produce an actual delay.
-}
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 =
    (Automaton (ScheduleT Integer m) () (Integer, ()), Integer)
-> FreeT
     (Wait Integer)
     m
     (Automaton (ScheduleT Integer m) () (Integer, ()), Integer)
forall a. a -> FreeT (Wait Integer) m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( NonEmpty Integer -> Automaton (ScheduleT Integer m) () Integer
forall (m :: Type -> Type) a.
Monad m =>
NonEmpty a -> Automaton m () a
cycleS (Periodic v -> NonEmpty Integer
forall (v :: [Nat]).
NonemptyNatList v =>
Periodic v -> NonEmpty Integer
theList Periodic v
cl) Automaton (ScheduleT Integer m) () Integer
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
-> Automaton (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 ())
-> Automaton (ScheduleT Integer m) Integer Integer
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Automaton m a a
withSideEffect Integer -> FreeT (Wait Integer) m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait Automaton (ScheduleT Integer m) Integer Integer
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
-> Automaton (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 -> Automaton (ScheduleT Integer m) Integer Integer
forall (m :: Type -> Type) a b.
Monad m =>
(a -> b -> b) -> b -> Automaton m a b
accumulateWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
0 Automaton (ScheduleT Integer m) Integer Integer
-> Automaton (ScheduleT Integer m) Integer ()
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
forall b c c'.
Automaton (ScheduleT Integer m) b c
-> Automaton (ScheduleT Integer m) b c'
-> Automaton (ScheduleT Integer m) b (c, c')
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Integer -> ()) -> Automaton (ScheduleT Integer m) Integer ()
forall b c. (b -> c) -> Automaton (ScheduleT Integer m) b c
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)

-- * Type-level trickery to extract the type value from the singleton

data HeadClProxy (n :: Nat) where
  HeadClProxy :: Periodic (n : ns) -> HeadClProxy n

headCl :: (KnownNat n) => Periodic (n : ns) -> Integer
headCl :: forall (n :: Nat) (ns :: [Nat]).
KnownNat n =>
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) (n :: [Nat]). Periodic (n : n) -> HeadClProxy n
HeadClProxy Periodic (n : ns)
cl

tailCl :: Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)
tailCl :: forall (n1 :: Nat) (n2 :: Nat) (ns :: [Nat]).
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)

-- * Utilities

-- | Repeatedly outputs the values of a given list, in order.
cycleS :: (Monad m) => NonEmpty a -> Automaton m () a
cycleS :: forall (m :: Type -> Type) a.
Monad m =>
NonEmpty a -> Automaton m () a
cycleS NonEmpty a
as = Automaton m () [a] -> Automaton m () a
forall (m :: Type -> Type) b.
Monad m =>
Automaton m () [b] -> Automaton m () b
concatS (Automaton m () [a] -> Automaton m () a)
-> Automaton m () [a] -> Automaton m () a
forall a b. (a -> b) -> a -> b
$ (() -> [a]) -> Automaton m () [a]
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((() -> [a]) -> Automaton m () [a])
-> (() -> [a]) -> Automaton m () [a]
forall a b. (a -> b) -> a -> b
$ [a] -> () -> [a]
forall a b. a -> b -> a
const ([a] -> () -> [a]) -> [a] -> () -> [a]
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
toList NonEmpty a
as