Class.hs

{-# LANGUAGE TypeFamilies #-}
module Synthesizer.Causal.Class where

import qualified Control.Category as Cat
import Control.Arrow (Arrow, arr, (<<<), (>>>), (&&&), )

import Data.Function.HT (nest, )


class (Arrow process, ProcessOf (SignalOf process) ~ process) => C process where
   type SignalOf process :: * -> *
   type ProcessOf (signal :: * -> *) :: * -> * -> *
   toSignal :: process () a -> SignalOf process a
   fromSignal :: SignalOf process b -> process a b


infixl 0 $<, $>, $*
-- infixr 0 $:*   -- can be used together with $

apply ::
   (C process) => process a b -> SignalOf process a -> SignalOf process b
apply proc sig =
   toSignal (proc <<< fromSignal sig)

applyFst, ($<) ::
   (C process) => process (a,b) c -> SignalOf process a -> process b c
applyFst proc sig =
   proc <<< feedFst sig

applySnd, ($>) ::
   (C process) => process (a,b) c -> SignalOf process b -> process a c
applySnd proc sig =
   proc <<< feedSnd sig

feedFst :: (C process) => SignalOf process a -> process b (a,b)
feedFst sig =
   fromSignal sig &&& Cat.id

feedSnd :: (C process) => SignalOf process a -> process b (b,a)
feedSnd sig =
   Cat.id &&& fromSignal sig

{-
These infix operators may become methods of a type class
that can also have synthesizer-core:Causal.Process as instance.
-}
($*) ::
   (C process) =>
   process a b -> SignalOf process a -> SignalOf process b
($*) = apply
($<) = applyFst
($>) = applySnd



{-# INLINE chainControlled #-}
chainControlled ::
   (Arrow arrow) =>
   [arrow (c,x) x] -> arrow (c,x) x
chainControlled =
   foldr
      (\p rest -> arr fst &&& p  >>>  rest)
      (arr snd)

{-# INLINE replicateControlled #-}
replicateControlled ::
   (Arrow arrow) =>
   Int -> arrow (c,x) x -> arrow (c,x) x
replicateControlled n p =
   nest n
      (arr fst &&& p  >>> )
      (arr snd)